X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fexp_disp.adb;h=12cfbdc647059e961685699bc2e59276b87801f2;hb=4c97a37dc04bd1838ea3d099bebf2900e10322dd;hp=64a4f1fac0222b38ec673aaf278f0f2419ff504a;hpb=ef40be71e0683d4d602f3b4754d5337e9de6a041;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 64a4f1fac02..12cfbdc6470 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -30,7 +30,8 @@ with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Exp_Atag; use Exp_Atag; -with Exp_Ch7; use Exp_Ch7; +with Exp_Ch6; use Exp_Ch6; +with Exp_CG; use Exp_CG; with Exp_Dbug; use Exp_Dbug; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; @@ -59,6 +60,8 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; +with SCIL_LL; use SCIL_LL; +with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -72,6 +75,12 @@ package body Exp_Disp is -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table -- of the default primitive operations. + function Find_Specific_Type (CW : Entity_Id) return Entity_Id; + -- Find specific type of a class-wide type, and handle the case of an + -- incomplete type coming either from a limited_with clause or from an + -- incomplete type declaration. Shouldn't this be in Sem_Util? It seems + -- like a general purpose semantic routine ??? + function Has_DT (Typ : Entity_Id) return Boolean; pragma Inline (Has_DT); -- Returns true if we generate a dispatch table for tagged type Typ @@ -175,11 +184,7 @@ package body Exp_Disp is CW_Typ := Class_Wide_Type (Ctrl_Typ); end if; - Typ := Root_Type (CW_Typ); - - if Ekind (Typ) = E_Incomplete_Type then - Typ := Non_Limited_View (Typ); - end if; + Typ := Find_Specific_Type (CW_Typ); if not Is_Limited_Type (Typ) then Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); @@ -292,6 +297,7 @@ package body Exp_Disp is return Static_Dispatch_Tables and then Is_Library_Level_Tagged_Type (Typ) + and then VM_Target = No_VM -- If the type is derived from a CPP class we cannot statically -- build the dispatch tables because we must inherit primitives @@ -463,6 +469,103 @@ package body Exp_Disp is end Build_Static_Dispatch_Tables; ------------------------------ + -- Convert_Tag_To_Interface -- + ------------------------------ + + function Convert_Tag_To_Interface + (Typ : Entity_Id; + Expr : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Expr); + Anon_Type : Entity_Id; + Result : Node_Id; + + begin + pragma Assert (Is_Class_Wide_Type (Typ) + and then Is_Interface (Typ) + and then + ((Nkind (Expr) = N_Selected_Component + and then Is_Tag (Entity (Selector_Name (Expr)))) + or else + (Nkind (Expr) = N_Function_Call + and then RTE_Available (RE_Displace) + and then Entity (Name (Expr)) = RTE (RE_Displace)))); + + Anon_Type := Create_Itype (E_Anonymous_Access_Type, Expr); + Set_Directly_Designated_Type (Anon_Type, Typ); + Set_Etype (Anon_Type, Anon_Type); + Set_Can_Never_Be_Null (Anon_Type); + + -- Decorate the size and alignment attributes of the anonymous access + -- type, as required by gigi. + + Layout_Type (Anon_Type); + + if Nkind (Expr) = N_Selected_Component + and then Is_Tag (Entity (Selector_Name (Expr))) + then + Result := + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (Anon_Type, + Make_Attribute_Reference (Loc, + Prefix => Expr, + Attribute_Name => Name_Address))); + else + Result := + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (Anon_Type, Expr)); + end if; + + return Result; + end Convert_Tag_To_Interface; + + ------------------- + -- CPP_Num_Prims -- + ------------------- + + function CPP_Num_Prims (Typ : Entity_Id) return Nat is + CPP_Typ : Entity_Id; + Tag_Comp : Entity_Id; + + begin + if not Is_Tagged_Type (Typ) + or else not Is_CPP_Class (Root_Type (Typ)) + then + return 0; + + else + CPP_Typ := Enclosing_CPP_Parent (Typ); + Tag_Comp := First_Tag_Component (CPP_Typ); + + -- If the number of primitives is already set in the tag component + -- then use it + + if Present (Tag_Comp) + and then DT_Entry_Count (Tag_Comp) /= No_Uint + then + return UI_To_Int (DT_Entry_Count (Tag_Comp)); + + -- Otherwise, count the primitives of the enclosing CPP type + + else + declare + Count : Nat := 0; + Elmt : Elmt_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (CPP_Typ)); + while Present (Elmt) loop + Count := Count + 1; + Next_Elmt (Elmt); + end loop; + + return Count; + end; + end if; + end if; + end CPP_Num_Prims; + + ------------------------------ -- Default_Prim_Op_Position -- ------------------------------ @@ -478,51 +581,52 @@ package body Exp_Disp is if Chars (E) = Name_uSize then return Uint_1; - elsif Chars (E) = Name_uAlignment then + elsif TSS_Name = TSS_Stream_Read then return Uint_2; - elsif TSS_Name = TSS_Stream_Read then + elsif TSS_Name = TSS_Stream_Write then return Uint_3; - elsif TSS_Name = TSS_Stream_Write then + elsif TSS_Name = TSS_Stream_Input then return Uint_4; - elsif TSS_Name = TSS_Stream_Input then + elsif TSS_Name = TSS_Stream_Output then return Uint_5; - elsif TSS_Name = TSS_Stream_Output then + elsif Chars (E) = Name_Op_Eq then return Uint_6; - elsif Chars (E) = Name_Op_Eq then + elsif Chars (E) = Name_uAssign then return Uint_7; - elsif Chars (E) = Name_uAssign then + elsif TSS_Name = TSS_Deep_Adjust then return Uint_8; - elsif TSS_Name = TSS_Deep_Adjust then + elsif TSS_Name = TSS_Deep_Finalize then return Uint_9; - elsif TSS_Name = TSS_Deep_Finalize then - return Uint_10; + -- In VM targets unconditionally allow obtaining the position associated + -- with predefined interface primitives since in these platforms any + -- tagged type has these primitives. - elsif Ada_Version >= Ada_05 then + elsif Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion then if Chars (E) = Name_uDisp_Asynchronous_Select then - return Uint_11; + return Uint_10; elsif Chars (E) = Name_uDisp_Conditional_Select then - return Uint_12; + return Uint_11; elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then - return Uint_13; + return Uint_12; elsif Chars (E) = Name_uDisp_Get_Task_Id then - return Uint_14; + return Uint_13; elsif Chars (E) = Name_uDisp_Requeue then - return Uint_15; + return Uint_14; elsif Chars (E) = Name_uDisp_Timed_Select then - return Uint_16; + return Uint_15; end if; end if; @@ -577,8 +681,9 @@ package body Exp_Disp is -- Local variables - New_Node : Node_Id; - SCIL_Node : Node_Id; + New_Node : Node_Id; + SCIL_Node : Node_Id; + SCIL_Related_Node : Node_Id := Call_Node; -- Start of processing for Expand_Dispatching_Call @@ -589,13 +694,14 @@ package body Exp_Disp is end if; -- Expand_Dispatching_Call is called directly from the semantics, - -- so we need a check to see whether expansion is active before - -- proceeding. In addition, there is no need to expand the call - -- if we are compiling under restriction No_Dispatching_Calls; - -- the semantic analyzer has previously notified the violation - -- of this restriction. + -- so we only proceed if the expander is active. + + if not Full_Expander_Active + + -- And there is no need to expand the call if we are compiling under + -- restriction No_Dispatching_Calls; the semantic analyzer has + -- previously notified the violation of this restriction. - if not Expander_Active or else Restriction_Active (No_Dispatching_Calls) then return; @@ -642,24 +748,7 @@ package body Exp_Disp is CW_Typ := Class_Wide_Type (Ctrl_Typ); end if; - Typ := Root_Type (CW_Typ); - - if Ekind (Typ) = E_Incomplete_Type then - Typ := Non_Limited_View (Typ); - end if; - - -- Generate the SCIL node for this dispatching call. The SCIL node for a - -- dispatching call is inserted in the tree before the call is rewriten - -- and expanded because the SCIL node must be found by the SCIL backend - -- BEFORE the expanded nodes associated with the call node are found. - - if Generate_SCIL then - SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node)); - Set_SCIL_Related_Node (SCIL_Node, Call_Node); - Set_SCIL_Entity (SCIL_Node, Typ); - Set_SCIL_Target_Prim (SCIL_Node, Subp); - Insert_Action (Call_Node, SCIL_Node); - end if; + Typ := Find_Specific_Type (CW_Typ); if not Is_Limited_Type (Typ) then Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); @@ -692,7 +781,9 @@ package body Exp_Disp is Append_To (New_Params, Duplicate_Subexpr_Move_Checks (Param)); - else + elsif Nkind (Parent (Param)) /= N_Parameter_Association + or else not Is_Accessibility_Actual (Parent (Param)) + then Append_To (New_Params, Relocate_Node (Param)); end if; @@ -712,6 +803,11 @@ package body Exp_Disp is Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node); Set_Etype (Subp_Typ, Res_Typ); Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); + Set_Convention (Subp_Typ, Convention (Subp)); + + -- Notify gigi that the designated type is a dispatching primitive + + Set_Is_Dispatch_Table_Entity (Subp_Typ); -- Create a new list of parameters which is a copy of the old formal -- list including the creation of a new set of matching entities. @@ -811,11 +907,11 @@ package body Exp_Disp is else Controlling_Tag := Make_Selected_Component (Loc, - Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg), + Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg), Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc)); end if; - -- Handle dispatching calls to predefined primitives. + -- Handle dispatching calls to predefined primitives if Is_Predefined_Dispatching_Operation (Subp) or else Is_Predefined_Dispatching_Alias (Subp) @@ -829,7 +925,7 @@ package body Exp_Disp is else Build_Get_Prim_Op_Address (Loc, - Typ => Find_Dispatching_Type (Subp), + Typ => Underlying_Type (Find_Dispatching_Type (Subp)), Tag_Node => Controlling_Tag, Position => DT_Position (Subp), New_Node => New_Node); @@ -838,12 +934,16 @@ package body Exp_Disp is New_Call_Name := Unchecked_Convert_To (Subp_Ptr_Typ, New_Node); - -- Complete decoration of SCIL dispatching node. It must be done after - -- the new call name is built to reference the nodes that will see the - -- SCIL backend (because Build_Get_Prim_Op_Address generates an - -- unchecked type conversion which relocates the controlling tag node). + -- Generate the SCIL node for this dispatching call. Done now because + -- attribute SCIL_Controlling_Tag must be set after the new call name + -- is built to reference the nodes that will see the SCIL backend + -- (because Build_Get_Prim_Op_Address generates an unchecked type + -- conversion which relocates the controlling tag node). if Generate_SCIL then + SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node)); + Set_SCIL_Entity (SCIL_Node, Typ); + Set_SCIL_Target_Prim (SCIL_Node, Subp); -- Common case: the controlling tag is the tag of an object -- (for example, obj.tag) @@ -854,10 +954,10 @@ package body Exp_Disp is -- Handle renaming of selected component elsif Nkind (Controlling_Tag) = N_Identifier - and then Nkind (Parent (Entity (Controlling_Tag))) - = N_Object_Renaming_Declaration - and then Nkind (Name (Parent (Entity (Controlling_Tag)))) - = N_Selected_Component + and then Nkind (Parent (Entity (Controlling_Tag))) = + N_Object_Renaming_Declaration + and then Nkind (Name (Parent (Entity (Controlling_Tag)))) = + N_Selected_Component then Set_SCIL_Controlling_Tag (SCIL_Node, Name (Parent (Entity (Controlling_Tag)))); @@ -867,8 +967,8 @@ package body Exp_Disp is elsif Nkind (Controlling_Tag) = N_Identifier and then Nkind_In (Parent (Entity (Controlling_Tag)), - N_Object_Declaration, - N_Parameter_Specification) + N_Object_Declaration, + N_Parameter_Specification) then Set_SCIL_Controlling_Tag (SCIL_Node, Parent (Entity (Controlling_Tag))); @@ -879,14 +979,14 @@ package body Exp_Disp is elsif Nkind (Controlling_Tag) = N_Explicit_Dereference and then Nkind (Prefix (Controlling_Tag)) = N_Identifier and then Nkind_In (Parent (Entity (Prefix (Controlling_Tag))), - N_Object_Declaration, - N_Parameter_Specification) + N_Object_Declaration, + N_Parameter_Specification) then Set_SCIL_Controlling_Tag (SCIL_Node, Parent (Entity (Prefix (Controlling_Tag)))); -- For a direct reference of the tag of the type the SCIL node - -- references the the internal object declaration containing the tag + -- references the internal object declaration containing the tag -- of the type. elsif Nkind (Controlling_Tag) = N_Attribute_Reference @@ -894,9 +994,9 @@ package body Exp_Disp is then Set_SCIL_Controlling_Tag (SCIL_Node, Parent - (Node - (First_Elmt - (Access_Disp_Table (Entity (Prefix (Controlling_Tag))))))); + (Node + (First_Elmt + (Access_Disp_Table (Entity (Prefix (Controlling_Tag))))))); -- Interfaces are not supported. For now we leave the SCIL node -- decorated with the Controlling_Tag. More work needed here??? @@ -913,7 +1013,7 @@ package body Exp_Disp is if Nkind (Call_Node) = N_Function_Call then New_Call := Make_Function_Call (Loc, - Name => New_Call_Name, + Name => New_Call_Name, Parameter_Associations => New_Params); -- If this is a dispatching "=", we must first compare the tags so @@ -927,31 +1027,43 @@ package body Exp_Disp is Make_Op_Eq (Loc, Left_Opnd => Make_Selected_Component (Loc, - Prefix => New_Value (Param), + Prefix => New_Value (Param), Selector_Name => New_Reference_To (First_Tag_Component (Typ), Loc)), Right_Opnd => Make_Selected_Component (Loc, - Prefix => + Prefix => Unchecked_Convert_To (Typ, New_Value (Next_Actual (Param))), Selector_Name => - New_Reference_To (First_Tag_Component (Typ), - Loc))), + New_Reference_To + (First_Tag_Component (Typ), Loc))), Right_Opnd => New_Call); + + SCIL_Related_Node := Right_Opnd (New_Call); end if; else New_Call := Make_Procedure_Call_Statement (Loc, - Name => New_Call_Name, + Name => New_Call_Name, Parameter_Associations => New_Params); end if; + -- Register the dispatching call in the call graph nodes table + + Register_CG_Node (Call_Node); + Rewrite (Call_Node, New_Call); + -- Associate the SCIL node of this dispatching call + + if Generate_SCIL then + Set_SCIL_Node (SCIL_Related_Node, SCIL_Node); + end if; + -- Suppress all checks during the analysis of the expanded code -- to avoid the generation of spurious warnings under ZFP run-time. @@ -1001,6 +1113,10 @@ package body Exp_Disp is Iface_Typ := Corresponding_Record_Type (Iface_Typ); end if; + -- Handle private types + + Iface_Typ := Underlying_Type (Iface_Typ); + -- Freeze the entity associated with the target interface to have -- available the attribute Access_Disp_Table. @@ -1011,11 +1127,37 @@ package body Exp_Disp is and then Is_Interface (Iface_Typ))); if not Tagged_Type_Expansion then + if VM_Target /= No_VM then + if Is_Access_Type (Operand_Typ) then + Operand_Typ := Designated_Type (Operand_Typ); + end if; - -- For VM, just do a conversion ??? + if Is_Class_Wide_Type (Operand_Typ) then + Operand_Typ := Root_Type (Operand_Typ); + end if; + + if not Is_Static + and then Operand_Typ /= Iface_Typ + then + Insert_Action (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of + (RTE (RE_Check_Interface_Conversion), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Expression (N)), + Attribute_Name => Name_Tag), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Iface_Typ, Loc), + Attribute_Name => Name_Tag)))); + end if; + + -- Just do a conversion ??? + + Rewrite (N, Unchecked_Convert_To (Etype (N), N)); + Analyze (N); + end if; - Rewrite (N, Unchecked_Convert_To (Etype (N), N)); - Analyze (N); return; end if; @@ -1098,15 +1240,18 @@ package body Exp_Disp is pragma Assert (Iface_Tag /= Empty); -- Keep separate access types to interfaces because one internal - -- function is used to handle the null value (see following comment) + -- function is used to handle the null value (see following comments) if not Is_Access_Type (Etype (N)) then + + -- Statically displace the pointer to the object to reference + -- the component containing the secondary dispatch table. + Rewrite (N, - Unchecked_Convert_To (Etype (N), + Convert_Tag_To_Interface (Class_Wide_Type (Iface_Typ), Make_Selected_Component (Loc, Prefix => Relocate_Node (Expression (N)), - Selector_Name => - New_Occurrence_Of (Iface_Tag, Loc)))); + Selector_Name => New_Occurrence_Of (Iface_Tag, Loc)))); else -- Build internal function to handle the case in which the @@ -1146,8 +1291,7 @@ package body Exp_Disp is New_Typ_Decl := Make_Full_Type_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('T')), + Defining_Identifier => Make_Temporary (Loc, 'T'), Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, @@ -1188,10 +1332,7 @@ package body Exp_Disp is Else_Statements => Stats)); end if; - Fent := - Make_Defining_Identifier (Loc, - New_Internal_Name ('F')); - + Fent := Make_Temporary (Loc, 'F'); Func := Make_Subprogram_Body (Loc, Specification => @@ -1317,7 +1458,7 @@ package body Exp_Disp is and then Is_Class_Wide_Type (Formal_Typ) then -- No need to displace the pointer if the type of the actual - -- coindices with the type of the formal. + -- coincides with the type of the formal. if Actual_Typ = Formal_Typ then null; @@ -1326,13 +1467,28 @@ package body Exp_Disp is -- a parent of the type of the actual because in this case the -- interface primitives are located in the primary dispatch table. - elsif Is_Ancestor (Formal_Typ, Actual_Typ) then + elsif Is_Ancestor (Formal_Typ, Actual_Typ, + Use_Full_View => True) + then null; -- Implicit conversion to the class-wide formal type to force -- the displacement of the pointer. else + -- Normally, expansion of actuals for calls to build-in-place + -- functions happens as part of Expand_Actuals, but in this + -- case the call will be wrapped in a conversion and soon after + -- expanded further to handle the displacement for a class-wide + -- interface conversion, so if this is a BIP call then we need + -- to handle it now. + + if Ada_Version >= Ada_2005 + and then Is_Build_In_Place_Function_Call (Actual) + then + Make_Build_In_Place_Call_In_Anonymous_Context (Actual); + end if; + Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual)); Rewrite (Actual, Conversion); Analyze_And_Resolve (Actual, Formal_Typ); @@ -1372,7 +1528,9 @@ package body Exp_Disp is -- a parent of the type of the actual because in this case the -- interface primitives are located in the primary dispatch table. - elsif Is_Ancestor (Formal_DDT, Actual_DDT) then + elsif Is_Ancestor (Formal_DDT, Actual_DDT, + Use_Full_View => True) + then null; else @@ -1441,44 +1599,73 @@ package body Exp_Disp is Thunk_Id : out Entity_Id; Thunk_Code : out Node_Id) is - Loc : constant Source_Ptr := Sloc (Prim); - Actuals : constant List_Id := New_List; - Decl : constant List_Id := New_List; - Formals : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Prim); + Actuals : constant List_Id := New_List; + Decl : constant List_Id := New_List; + Formals : constant List_Id := New_List; + Target : constant Entity_Id := Ultimate_Alias (Prim); Controlling_Typ : Entity_Id; Decl_1 : Node_Id; Decl_2 : Node_Id; + Expr : Node_Id; Formal : Node_Id; + Ftyp : Entity_Id; + Iface_Formal : Node_Id; New_Arg : Node_Id; Offset_To_Top : Node_Id; - Target : Entity_Id; Target_Formal : Entity_Id; begin Thunk_Id := Empty; Thunk_Code := Empty; - -- Traverse the list of alias to find the final target + -- No thunk needed if the primitive has been eliminated - Target := Prim; - while Present (Alias (Target)) loop - Target := Alias (Target); - end loop; + if Is_Eliminated (Ultimate_Alias (Prim)) then + return; - -- In case of primitives that are functions without formals and - -- a controlling result there is no need to build the thunk. + -- In case of primitives that are functions without formals and a + -- controlling result there is no need to build the thunk. - if not Present (First_Formal (Target)) then + elsif not Present (First_Formal (Target)) then pragma Assert (Ekind (Target) = E_Function and then Has_Controlling_Result (Target)); return; end if; - -- Duplicate the formals + -- Duplicate the formals of the Target primitive. In the thunk, the type + -- of the controlling formal is the covered interface type (instead of + -- the target tagged type). Done to avoid problems with discriminated + -- tagged types because, if the controlling type has discriminants with + -- default values, then the type conversions done inside the body of + -- the thunk (after the displacement of the pointer to the base of the + -- actual object) generate code that modify its contents. + + -- Note: This special management is not done for predefined primitives + -- because??? + + if not Is_Predefined_Dispatching_Operation (Prim) then + Iface_Formal := First_Formal (Interface_Alias (Prim)); + end if; Formal := First_Formal (Target); while Present (Formal) loop + Ftyp := Etype (Formal); + + -- Use the interface type as the type of the controlling formal (see + -- comment above). + + if not Is_Controlling_Formal (Formal) + or else Is_Predefined_Dispatching_Operation (Prim) + then + Ftyp := Etype (Formal); + Expr := New_Copy_Tree (Expression (Parent (Formal))); + else + Ftyp := Etype (Iface_Formal); + Expr := Empty; + end if; + Append_To (Formals, Make_Parameter_Specification (Loc, Defining_Identifier => @@ -1486,9 +1673,12 @@ package body Exp_Disp is Chars => Chars (Formal)), In_Present => In_Present (Parent (Formal)), Out_Present => Out_Present (Parent (Formal)), - Parameter_Type => - New_Reference_To (Etype (Formal), Loc), - Expression => New_Copy_Tree (Expression (Parent (Formal))))); + Parameter_Type => New_Reference_To (Ftyp, Loc), + Expression => Expr)); + + if not Is_Predefined_Dispatching_Operation (Prim) then + Next_Formal (Iface_Formal); + end if; Next_Formal (Formal); end loop; @@ -1498,31 +1688,46 @@ package body Exp_Disp is Target_Formal := First_Formal (Target); Formal := First (Formals); while Present (Formal) loop + + -- If the parent is a constrained discriminated type, then the + -- primitive operation will have been defined on a first subtype. + -- For proper matching with controlling type, use base type. + if Ekind (Target_Formal) = E_In_Parameter and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type - and then Directly_Designated_Type (Etype (Target_Formal)) - = Controlling_Typ then - -- Generate: + Ftyp := + Base_Type (Directly_Designated_Type (Etype (Target_Formal))); + else + Ftyp := Base_Type (Etype (Target_Formal)); + end if; + -- For concurrent types, the relevant information is found in the + -- Corresponding_Record_Type, rather than the type entity itself. + + if Is_Concurrent_Type (Ftyp) then + Ftyp := Corresponding_Record_Type (Ftyp); + end if; + + if Ekind (Target_Formal) = E_In_Parameter + and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type + and then Ftyp = Controlling_Typ + then + -- Generate: -- type T is access all <> -- S : Storage_Offset := Storage_Offset!(Formal) -- - Offset_To_Top (address!(Formal)) Decl_2 := Make_Full_Type_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('T')), + Defining_Identifier => Make_Temporary (Loc, 'T'), Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, Null_Exclusion_Present => False, Constant_Present => False, Subtype_Indication => - New_Reference_To - (Directly_Designated_Type - (Etype (Target_Formal)), Loc))); + New_Reference_To (Ftyp, Loc))); New_Arg := Unchecked_Convert_To (RTE (RE_Address), @@ -1540,9 +1745,7 @@ package body Exp_Disp is Decl_1 := Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')), + Defining_Identifier => Make_Temporary (Loc, 'S'), Constant_Present => True, Object_Definition => New_Reference_To (RTE (RE_Storage_Offset), Loc), @@ -1566,9 +1769,9 @@ package body Exp_Disp is (Defining_Identifier (Decl_2), New_Reference_To (Defining_Identifier (Decl_1), Loc))); - elsif Etype (Target_Formal) = Controlling_Typ then - -- Generate: + elsif Ftyp = Controlling_Typ then + -- Generate: -- S1 : Storage_Offset := Storage_Offset!(Formal'Address) -- - Offset_To_Top (Formal'Address) -- S2 : Addr_Ptr := Addr_Ptr!(S1) @@ -1592,8 +1795,7 @@ package body Exp_Disp is Decl_1 := Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('S')), + Defining_Identifier => Make_Temporary (Loc, 'S'), Constant_Present => True, Object_Definition => New_Reference_To (RTE (RE_Storage_Offset), Loc), @@ -1612,11 +1814,11 @@ package body Exp_Disp is Decl_2 := Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('S')), - Constant_Present => True, - Object_Definition => New_Reference_To (RTE (RE_Addr_Ptr), Loc), - Expression => + Defining_Identifier => Make_Temporary (Loc, 'S'), + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Addr_Ptr), Loc), + Expression => Unchecked_Convert_To (RTE (RE_Addr_Ptr), New_Reference_To (Defining_Identifier (Decl_1), Loc))); @@ -1624,12 +1826,11 @@ package body Exp_Disp is Append_To (Decl, Decl_1); Append_To (Decl, Decl_2); - -- Reference the new actual. Generate: + -- Reference the new actual, generate: -- Target_Formal (S2.all) Append_To (Actuals, - Unchecked_Convert_To - (Etype (Target_Formal), + Unchecked_Convert_To (Ftyp, Make_Explicit_Dereference (Loc, New_Reference_To (Defining_Identifier (Decl_2), Loc)))); @@ -1644,11 +1845,11 @@ package body Exp_Disp is Next (Formal); end loop; - Thunk_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); - + Thunk_Id := Make_Temporary (Loc, 'T'); Set_Is_Thunk (Thunk_Id); + Set_Convention (Thunk_Id, Convention (Prim)); + + -- Procedure case if Ekind (Target) = E_Procedure then Thunk_Code := @@ -1665,8 +1866,9 @@ package body Exp_Disp is Name => New_Occurrence_Of (Target, Loc), Parameter_Associations => Actuals)))); - else pragma Assert (Ekind (Target) = E_Function); + -- Function case + else pragma Assert (Ekind (Target) = E_Function); Thunk_Code := Make_Subprogram_Body (Loc, Specification => @@ -1686,6 +1888,49 @@ package body Exp_Disp is end if; end Expand_Interface_Thunk; + ------------------------ + -- Find_Specific_Type -- + ------------------------ + + function Find_Specific_Type (CW : Entity_Id) return Entity_Id is + Typ : Entity_Id := Root_Type (CW); + + begin + if Ekind (Typ) = E_Incomplete_Type then + if From_With_Type (Typ) then + Typ := Non_Limited_View (Typ); + else + Typ := Full_View (Typ); + end if; + end if; + + return Typ; + end Find_Specific_Type; + + -------------------------- + -- Has_CPP_Constructors -- + -------------------------- + + function Has_CPP_Constructors (Typ : Entity_Id) return Boolean is + E : Entity_Id; + + begin + -- Look for the constructor entities + + E := Next_Entity (Typ); + while Present (E) loop + if Ekind (E) = E_Function + and then Is_Constructor (E) + then + return True; + end if; + + Next_Entity (E); + end loop; + + return False; + end Has_CPP_Constructors; + ------------ -- Has_DT -- ------------ @@ -1720,14 +1965,13 @@ package body Exp_Disp is TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); if Chars (E) = Name_uSize - or else Chars (E) = Name_uAlignment or else TSS_Name = TSS_Stream_Read or else TSS_Name = TSS_Stream_Write or else TSS_Name = TSS_Stream_Input or else TSS_Name = TSS_Stream_Output or else (Chars (E) = Name_Op_Eq - and then Etype (First_Entity (E)) = Etype (Last_Entity (E))) + and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) or else Chars (E) = Name_uAssign or else TSS_Name = TSS_Deep_Adjust or else TSS_Name = TSS_Deep_Finalize @@ -1740,29 +1984,57 @@ package body Exp_Disp is return False; end Is_Predefined_Dispatching_Operation; - ------------------------------------- - -- Is_Predefined_Dispatching_Alias -- - ------------------------------------- + --------------------------------------- + -- Is_Predefined_Internal_Operation -- + --------------------------------------- - function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean + function Is_Predefined_Internal_Operation + (E : Entity_Id) return Boolean is - E : Entity_Id; + TSS_Name : TSS_Name_Type; begin - if not Is_Predefined_Dispatching_Operation (Prim) - and then Present (Alias (Prim)) - then - E := Prim; - while Present (Alias (E)) loop - E := Alias (E); - end loop; + if not Is_Dispatching_Operation (E) then + return False; + end if; + + Get_Name_String (Chars (E)); - if Is_Predefined_Dispatching_Operation (E) then + -- Most predefined primitives have internally generated names. Equality + -- must be treated differently; the predefined operation is recognized + -- as a homogeneous binary operator that returns Boolean. + + if Name_Len > TSS_Name_Type'Last then + TSS_Name := + TSS_Name_Type + (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); + + if Chars (E) = Name_uSize + or else + (Chars (E) = Name_Op_Eq + and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) + or else Chars (E) = Name_uAssign + or else TSS_Name = TSS_Deep_Adjust + or else TSS_Name = TSS_Deep_Finalize + or else Is_Predefined_Interface_Primitive (E) + then return True; end if; end if; return False; + end Is_Predefined_Internal_Operation; + + ------------------------------------- + -- Is_Predefined_Dispatching_Alias -- + ------------------------------------- + + function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean + is + begin + return not Is_Predefined_Dispatching_Operation (Prim) + and then Present (Alias (Prim)) + and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim)); end Is_Predefined_Dispatching_Alias; --------------------------------------- @@ -1771,7 +2043,11 @@ package body Exp_Disp is function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is begin - return Ada_Version >= Ada_05 + -- In VM targets we don't restrict the functionality of this test to + -- compiling in Ada 2005 mode since in VM targets any tagged type has + -- these primitives + + return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion) and then (Chars (E) = Name_uDisp_Asynchronous_Select or else Chars (E) = Name_uDisp_Conditional_Select or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind or else @@ -1794,7 +2070,8 @@ package body Exp_Disp is -- F : out Boolean) -- is -- begin - -- null; + -- F := False; + -- C := Ada.Tags.POK_Function; -- end _Disp_Asynchronous_Select; -- For protected types, generate: @@ -1846,10 +2123,10 @@ package body Exp_Disp is Com_Block : Entity_Id; Conc_Typ : Entity_Id := Empty; Decls : constant List_Id := New_List; - DT_Ptr : Entity_Id; Loc : constant Source_Ptr := Sloc (Typ); Obj_Ref : Node_Id; Stmts : constant List_Id := New_List; + Tag_Node : Node_Id; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); @@ -1859,17 +2136,15 @@ package body Exp_Disp is if Is_Interface (Typ) then return Make_Subprogram_Body (Loc, - Specification => - Make_Disp_Asynchronous_Select_Spec (Typ), - Declarations => - New_List, + Specification => Make_Disp_Asynchronous_Select_Spec (Typ), + Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - New_List (Make_Null_Statement (Loc)))); + New_List (Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => New_Reference_To (Standard_False, Loc))))); end if; - DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); - if Is_Concurrent_Record_Type (Typ) then Conc_Typ := Corresponding_Concurrent_Type (Typ); @@ -1880,6 +2155,18 @@ package body Exp_Disp is -- where I will be used to capture the entry index of the primitive -- wrapper at position S. + if Tagged_Type_Expansion then + Tag_Node := + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)); + else + Tag_Node := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Typ, Loc), + Attribute_Name => Name_Tag); + end if; + Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => @@ -1892,8 +2179,7 @@ package body Exp_Disp is New_Reference_To (RTE (RE_Get_Entry_Index), Loc), Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (DT_Ptr, Loc)), + Tag_Node, Make_Identifier (Loc, Name_uS))))); if Ekind (Conc_Typ) = E_Protected_Type then @@ -1901,9 +2187,7 @@ package body Exp_Disp is -- Generate: -- Bnn : Communication_Block; - Com_Block := - Make_Defining_Identifier (Loc, New_Internal_Name ('B')); - + Com_Block := Make_Temporary (Loc, 'B'); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => @@ -1947,12 +2231,12 @@ package body Exp_Disp is Make_Unchecked_Type_Conversion (Loc, -- entry index Subtype_Mark => New_Reference_To - (RTE (RE_Protected_Entry_Index), Loc), + (RTE (RE_Protected_Entry_Index), Loc), Expression => Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uP), -- parameter block - New_Reference_To ( -- Asynchronous_Call - RTE (RE_Asynchronous_Call), Loc), + New_Reference_To -- Asynchronous_Call + (RTE (RE_Asynchronous_Call), Loc), New_Reference_To (Com_Block, Loc)))); -- comm block @@ -1974,7 +2258,7 @@ package body Exp_Disp is Obj_Ref, Make_Attribute_Reference (Loc, - Prefix => Make_Identifier (Loc, Name_uP), + Prefix => Make_Identifier (Loc, Name_uP), Attribute_Name => Name_Address), New_Reference_To @@ -1989,8 +2273,7 @@ package body Exp_Disp is Append_To (Stmts, Make_Assignment_Statement (Loc, - Name => - Make_Identifier (Loc, Name_uB), + Name => Make_Identifier (Loc, Name_uB), Expression => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => @@ -1999,8 +2282,16 @@ package body Exp_Disp is Expression => New_Reference_To (Com_Block, Loc)))); - else - pragma Assert (Ekind (Conc_Typ) = E_Task_Type); + -- Generate: + -- F := False; + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => New_Reference_To (Standard_False, Loc))); + + else + pragma Assert (Ekind (Conc_Typ) = E_Task_Type); -- Generate: -- Task_Entry_Call @@ -2020,35 +2311,34 @@ package body Exp_Disp is Parameter_Associations => New_List ( Make_Selected_Component (Loc, -- T._task_id - Prefix => - Make_Identifier (Loc, Name_uT), - Selector_Name => - Make_Identifier (Loc, Name_uTask_Id)), + Prefix => Make_Identifier (Loc, Name_uT), + Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), Make_Unchecked_Type_Conversion (Loc, -- entry index Subtype_Mark => New_Reference_To (RTE (RE_Task_Entry_Index), Loc), - Expression => - Make_Identifier (Loc, Name_uI)), + Expression => Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uP), -- parameter block - New_Reference_To ( -- Asynchronous_Call - RTE (RE_Asynchronous_Call), Loc), + New_Reference_To -- Asynchronous_Call + (RTE (RE_Asynchronous_Call), Loc), Make_Identifier (Loc, Name_uF)))); -- status flag end if; else -- Ensure that the statements list is non-empty - Append_To (Stmts, Make_Null_Statement (Loc)); + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => New_Reference_To (Standard_False, Loc))); end if; return Make_Subprogram_Body (Loc, - Specification => + Specification => Make_Disp_Asynchronous_Select_Spec (Typ), - Declarations => - Decls, + Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Stmts)); end Make_Disp_Asynchronous_Select_Body; @@ -2131,7 +2421,8 @@ package body Exp_Disp is -- F : out Boolean) -- is -- begin - -- null; + -- F := False; + -- C := Ada.Tags.POK_Function; -- end _Disp_Conditional_Select; -- For protected types, generate: @@ -2196,9 +2487,9 @@ package body Exp_Disp is Blk_Nam : Entity_Id; Conc_Typ : Entity_Id := Empty; Decls : constant List_Id := New_List; - DT_Ptr : Entity_Id; Obj_Ref : Node_Id; Stmts : constant List_Id := New_List; + Tag_Node : Node_Id; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); @@ -2214,11 +2505,11 @@ package body Exp_Disp is No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - New_List (Make_Null_Statement (Loc)))); + New_List (Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => New_Reference_To (Standard_False, Loc))))); end if; - DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); - if Is_Concurrent_Record_Type (Typ) then Conc_Typ := Corresponding_Concurrent_Type (Typ); @@ -2246,7 +2537,7 @@ package body Exp_Disp is -- return; -- end if; - Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts); + Build_Common_Dispatching_Select_Statements (Typ, Stmts); -- Generate: -- Bnn : Communication_Block; @@ -2254,8 +2545,7 @@ package body Exp_Disp is -- where Bnn is the name of the communication block used in the -- call to Protected_Entry_Call. - Blk_Nam := Make_Defining_Identifier (Loc, New_Internal_Name ('B')); - + Blk_Nam := Make_Temporary (Loc, 'B'); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => @@ -2268,18 +2558,29 @@ package body Exp_Disp is -- I is the entry index and S is the dispatch table slot + if Tagged_Type_Expansion then + Tag_Node := + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)); + + else + Tag_Node := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Typ, Loc), + Attribute_Name => Name_Tag); + end if; + Append_To (Stmts, Make_Assignment_Statement (Loc, - Name => - Make_Identifier (Loc, Name_uI), + Name => Make_Identifier (Loc, Name_uI), Expression => Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc), Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (DT_Ptr, Loc)), + Tag_Node, Make_Identifier (Loc, Name_uS))))); if Ekind (Conc_Typ) = E_Protected_Type then @@ -2343,7 +2644,7 @@ package body Exp_Disp is Obj_Ref, Make_Attribute_Reference (Loc, - Prefix => Make_Identifier (Loc, Name_uP), + Prefix => Make_Identifier (Loc, Name_uP), Attribute_Name => Name_Address), New_Reference_To @@ -2360,8 +2661,7 @@ package body Exp_Disp is Append_To (Stmts, Make_Assignment_Statement (Loc, - Name => - Make_Identifier (Loc, Name_uF), + Name => Make_Identifier (Loc, Name_uF), Expression => Make_Op_Not (Loc, Right_Opnd => @@ -2393,35 +2693,38 @@ package body Exp_Disp is New_List ( Make_Selected_Component (Loc, -- T._task_id - Prefix => - Make_Identifier (Loc, Name_uT), - Selector_Name => - Make_Identifier (Loc, Name_uTask_Id)), + Prefix => Make_Identifier (Loc, Name_uT), + Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), Make_Unchecked_Type_Conversion (Loc, -- entry index Subtype_Mark => New_Reference_To (RTE (RE_Task_Entry_Index), Loc), - Expression => - Make_Identifier (Loc, Name_uI)), + Expression => Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uP), -- parameter block - New_Reference_To ( -- Conditional_Call - RTE (RE_Conditional_Call), Loc), + New_Reference_To -- Conditional_Call + (RTE (RE_Conditional_Call), Loc), Make_Identifier (Loc, Name_uF)))); -- status flag end if; else - -- Ensure that the statements list is non-empty + -- Initialize out parameters - Append_To (Stmts, Make_Null_Statement (Loc)); + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => New_Reference_To (Standard_False, Loc))); + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uC), + Expression => New_Reference_To (RTE (RE_POK_Function), Loc))); end if; return Make_Subprogram_Body (Loc, - Specification => + Specification => Make_Disp_Conditional_Select_Spec (Typ), - Declarations => - Decls, + Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Stmts)); end Make_Disp_Conditional_Select_Body; @@ -2497,8 +2800,8 @@ package body Exp_Disp is function Make_Disp_Get_Prim_Op_Kind_Body (Typ : Entity_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (Typ); - DT_Ptr : Entity_Id; + Loc : constant Source_Ptr := Sloc (Typ); + Tag_Node : Node_Id; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); @@ -2515,14 +2818,25 @@ package body Exp_Disp is New_List (Make_Null_Statement (Loc)))); end if; - DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); - -- Generate: -- C := get_prim_op_kind (tag! (VP), S); -- where C is the out parameter capturing the call kind and S is the -- dispatch table slot number. + if Tagged_Type_Expansion then + Tag_Node := + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)); + + else + Tag_Node := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Typ, Loc), + Attribute_Name => Name_Tag); + end if; + return Make_Subprogram_Body (Loc, Specification => @@ -2540,9 +2854,8 @@ package body Exp_Disp is Name => New_Reference_To (RTE (RE_Get_Prim_Op_Kind), Loc), Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (DT_Ptr, Loc)), - Make_Identifier (Loc, Name_uS))))))); + Tag_Node, + Make_Identifier (Loc, Name_uS))))))); end Make_Disp_Get_Prim_Op_Kind_Body; ------------------------------------- @@ -2621,10 +2934,8 @@ package body Exp_Disp is New_Reference_To (RTE (RE_Address), Loc), Expression => Make_Selected_Component (Loc, - Prefix => - Make_Identifier (Loc, Name_uT), - Selector_Name => - Make_Identifier (Loc, Name_uTask_Id)))); + Prefix => Make_Identifier (Loc, Name_uT), + Selector_Name => Make_Identifier (Loc, Name_uTask_Id)))); -- A null body is constructed for non-task types @@ -2731,8 +3042,7 @@ package body Exp_Disp is else Append_To (Stmts, Make_If_Statement (Loc, - Condition => - Make_Identifier (Loc, Name_uF), + Condition => Make_Identifier (Loc, Name_uF), Then_Statements => New_List ( @@ -2758,7 +3068,7 @@ package body Exp_Disp is Name_Unchecked_Access, Prefix => Make_Selected_Component (Loc, - Prefix => + Prefix => Make_Identifier (Loc, Name_uO), Selector_Name => Make_Identifier (Loc, Name_uObject))), @@ -2767,8 +3077,7 @@ package body Exp_Disp is Subtype_Mark => New_Reference_To ( RTE (RE_Protected_Entry_Index), Loc), - Expression => - Make_Identifier (Loc, Name_uI)), + Expression => Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uA)))), -- abort status @@ -2822,70 +3131,55 @@ package body Exp_Disp is Append_To (Stmts, Make_If_Statement (Loc, - Condition => - Make_Identifier (Loc, Name_uF), + Condition => Make_Identifier (Loc, Name_uF), - Then_Statements => - New_List ( + Then_Statements => New_List ( - -- Call to Requeue_Protected_To_Task_Entry + -- Call to Requeue_Protected_To_Task_Entry - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To ( - RTE (RE_Requeue_Protected_To_Task_Entry), Loc), + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To + (RTE (RE_Requeue_Protected_To_Task_Entry), Loc), + + Parameter_Associations => New_List ( - Parameter_Associations => - New_List ( + Make_Unchecked_Type_Conversion (Loc, -- PEA (P) + Subtype_Mark => + New_Reference_To + (RTE (RE_Protection_Entries_Access), Loc), + Expression => Make_Identifier (Loc, Name_uP)), - Make_Unchecked_Type_Conversion (Loc, -- PEA (P) - Subtype_Mark => - New_Reference_To ( - RTE (RE_Protection_Entries_Access), Loc), - Expression => - Make_Identifier (Loc, Name_uP)), + Make_Selected_Component (Loc, -- O._task_id + Prefix => Make_Identifier (Loc, Name_uO), + Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), - Make_Selected_Component (Loc, -- O._task_id - Prefix => - Make_Identifier (Loc, Name_uO), - Selector_Name => - Make_Identifier (Loc, Name_uTask_Id)), + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To (RTE (RE_Task_Entry_Index), Loc), + Expression => Make_Identifier (Loc, Name_uI)), - Make_Unchecked_Type_Conversion (Loc, -- entry index - Subtype_Mark => - New_Reference_To ( - RTE (RE_Task_Entry_Index), Loc), - Expression => - Make_Identifier (Loc, Name_uI)), + Make_Identifier (Loc, Name_uA)))), -- abort status - Make_Identifier (Loc, Name_uA)))), -- abort status + Else_Statements => New_List ( - Else_Statements => - New_List ( + -- Call to Requeue_Task_Entry - -- Call to Requeue_Task_Entry + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc), - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc), - - Parameter_Associations => - New_List ( - - Make_Selected_Component (Loc, -- O._task_id - Prefix => - Make_Identifier (Loc, Name_uO), - Selector_Name => - Make_Identifier (Loc, Name_uTask_Id)), - - Make_Unchecked_Type_Conversion (Loc, -- entry index - Subtype_Mark => - New_Reference_To ( - RTE (RE_Task_Entry_Index), Loc), - Expression => - Make_Identifier (Loc, Name_uI)), - - Make_Identifier (Loc, Name_uA)))))); -- abort status + Parameter_Associations => New_List ( + + Make_Selected_Component (Loc, -- O._task_id + Prefix => Make_Identifier (Loc, Name_uO), + Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To (RTE (RE_Task_Entry_Index), Loc), + Expression => Make_Identifier (Loc, Name_uI)), + + Make_Identifier (Loc, Name_uA)))))); -- abort status end if; -- Even though no declarations are needed in both cases, we allocate @@ -2980,7 +3274,8 @@ package body Exp_Disp is -- F : out Boolean) -- is -- begin - -- null; + -- F := False; + -- C := Ada.Tags.POK_Function; -- end _Disp_Timed_Select; -- For protected types, generate: @@ -3039,7 +3334,7 @@ package body Exp_Disp is -- P, -- D, -- M, - -- D); + -- F); -- end _Disp_Time_Select; function Make_Disp_Timed_Select_Body @@ -3048,9 +3343,9 @@ package body Exp_Disp is Loc : constant Source_Ptr := Sloc (Typ); Conc_Typ : Entity_Id := Empty; Decls : constant List_Id := New_List; - DT_Ptr : Entity_Id; Obj_Ref : Node_Id; Stmts : constant List_Id := New_List; + Tag_Node : Node_Id; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); @@ -3066,11 +3361,12 @@ package body Exp_Disp is New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - New_List (Make_Null_Statement (Loc)))); + New_List ( + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => New_Reference_To (Standard_False, Loc))))); end if; - DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); - if Is_Concurrent_Record_Type (Typ) then Conc_Typ := Corresponding_Concurrent_Type (Typ); @@ -3082,10 +3378,8 @@ package body Exp_Disp is Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uI), - Object_Definition => - New_Reference_To (Standard_Integer, Loc))); + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI), + Object_Definition => New_Reference_To (Standard_Integer, Loc))); -- Generate: -- C := Get_Prim_Op_Kind (tag! (VP), S); @@ -3098,25 +3392,35 @@ package body Exp_Disp is -- return; -- end if; - Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts); + Build_Common_Dispatching_Select_Statements (Typ, Stmts); -- Generate: -- I := Get_Entry_Index (tag! (VP), S); -- I is the entry index and S is the dispatch table slot + if Tagged_Type_Expansion then + Tag_Node := + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)); + + else + Tag_Node := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Typ, Loc), + Attribute_Name => Name_Tag); + end if; + Append_To (Stmts, Make_Assignment_Statement (Loc, - Name => - Make_Identifier (Loc, Name_uI), + Name => Make_Identifier (Loc, Name_uI), Expression => Make_Function_Call (Loc, - Name => - New_Reference_To (RTE (RE_Get_Entry_Index), Loc), + Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc), Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (DT_Ptr, Loc)), + Tag_Node, Make_Identifier (Loc, Name_uS))))); -- Protected case @@ -3221,16 +3525,13 @@ package body Exp_Disp is New_List ( Make_Selected_Component (Loc, -- T._task_id - Prefix => - Make_Identifier (Loc, Name_uT), - Selector_Name => - Make_Identifier (Loc, Name_uTask_Id)), + Prefix => Make_Identifier (Loc, Name_uT), + Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), Make_Unchecked_Type_Conversion (Loc, -- entry index Subtype_Mark => New_Reference_To (RTE (RE_Task_Entry_Index), Loc), - Expression => - Make_Identifier (Loc, Name_uI)), + Expression => Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uP), -- parameter block Make_Identifier (Loc, Name_uD), -- delay @@ -3239,17 +3540,22 @@ package body Exp_Disp is end if; else - -- Ensure that the statements list is non-empty + -- Initialize out parameters - Append_To (Stmts, Make_Null_Statement (Loc)); + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => New_Reference_To (Standard_False, Loc))); + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uC), + Expression => New_Reference_To (RTE (RE_POK_Function), Loc))); end if; return Make_Subprogram_Body (Loc, - Specification => - Make_Disp_Timed_Select_Spec (Typ), - Declarations => - Decls, + Specification => Make_Disp_Timed_Select_Spec (Typ), + Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Stmts)); end Make_Disp_Timed_Select_Body; @@ -3376,7 +3682,10 @@ package body Exp_Disp is DT_Aggr : constant Elist_Id := New_Elmt_List; -- Entities marked with attribute Is_Dispatch_Table_Entity - procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id); + procedure Check_Premature_Freezing + (Subp : Entity_Id; + Tagged_Type : Entity_Id; + Typ : Entity_Id); -- Verify that all non-tagged types in the profile of a subprogram -- are frozen at the point the subprogram is frozen. This enforces -- the rule on RM 13.14 (14) as modified by AI05-019. At the point a @@ -3387,6 +3696,8 @@ package body Exp_Disp is -- Typical violation of the rule involves an object declaration that -- freezes a tagged type, when one of its primitive operations has a -- type in its profile whose full view has not been analyzed yet. + -- More complex cases involve composite types that have one private + -- unfrozen subcomponent. procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0); -- Export the dispatch table DT of tagged type Typ. Required to generate @@ -3415,33 +3726,107 @@ package body Exp_Disp is -- calls through interface types; the latter secondary table is -- generated when Build_Thunks is False, and provides support for -- Generic Dispatching Constructors that dispatch calls through - -- interface types. When constructing this latter table the value - -- of Suffix_Index is -1 to indicate that there is no need to export - -- such table when building statically allocated dispatch tables; a - -- positive value of Suffix_Index must match the Suffix_Index value - -- assigned to this secondary dispatch table by Make_Tags when its - -- unique external name was generated. + -- interface types. When constructing this latter table the value of + -- Suffix_Index is -1 to indicate that there is no need to export such + -- table when building statically allocated dispatch tables; a positive + -- value of Suffix_Index must match the Suffix_Index value assigned to + -- this secondary dispatch table by Make_Tags when its unique external + -- name was generated. ------------------------------ -- Check_Premature_Freezing -- ------------------------------ - procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id) is + procedure Check_Premature_Freezing + (Subp : Entity_Id; + Tagged_Type : Entity_Id; + Typ : Entity_Id) + is + Comp : Entity_Id; + + function Is_Actual_For_Formal_Incomplete_Type + (T : Entity_Id) return Boolean; + -- In Ada 2012, if a nested generic has an incomplete formal type, + -- the actual may be (and usually is) a private type whose completion + -- appears later. It is safe to build the dispatch table in this + -- case, gigi will have full views available. + + ------------------------------------------ + -- Is_Actual_For_Formal_Incomplete_Type -- + ------------------------------------------ + + function Is_Actual_For_Formal_Incomplete_Type + (T : Entity_Id) return Boolean + is + Gen_Par : Entity_Id; + F : Node_Id; + + begin + if not Is_Generic_Instance (Current_Scope) + or else not Used_As_Generic_Actual (T) + then + return False; + + else + Gen_Par := Generic_Parent (Parent (Current_Scope)); + end if; + + F := + First + (Generic_Formal_Declarations + (Unit_Declaration_Node (Gen_Par))); + while Present (F) loop + if Ekind (Defining_Identifier (F)) = E_Incomplete_Type then + return True; + end if; + + Next (F); + end loop; + + return False; + end Is_Actual_For_Formal_Incomplete_Type; + + -- Start of processing for Check_Premature_Freezing + begin + -- Note that if the type is a (subtype of) a generic actual, the + -- actual will have been frozen by the instantiation. + if Present (N) - and then Is_Private_Type (Typ) + and then Is_Private_Type (Typ) and then No (Full_View (Typ)) and then not Is_Generic_Type (Typ) and then not Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) + and then not Is_Generic_Actual_Type (Typ) then Error_Msg_Sloc := Sloc (Subp); Error_Msg_NE ("declaration must appear after completion of type &", N, Typ); Error_Msg_NE ("\which is an untagged type in the profile of" - & " primitive operation & declared#", - N, Subp); + & " primitive operation & declared#", N, Subp); + + else + Comp := Private_Component (Typ); + + if not Is_Tagged_Type (Typ) + and then Present (Comp) + and then not Is_Frozen (Comp) + and then + not Is_Actual_For_Formal_Incomplete_Type (Comp) + then + Error_Msg_Sloc := Sloc (Subp); + Error_Msg_Node_2 := Subp; + Error_Msg_Name_1 := Chars (Tagged_Type); + Error_Msg_NE + ("declaration must appear after completion of type &", + N, Comp); + Error_Msg_NE + ("\which is a component of untagged type& in the profile of" + & " primitive & of type % that is frozen by the declaration ", + N, Typ); + end if; end if; end Check_Premature_Freezing; @@ -3500,13 +3885,8 @@ package body Exp_Disp is Exporting_Table : constant Boolean := Building_Static_DT (Typ) and then Suffix_Index > 0; - Iface_DT : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); - Name_Predef_Prims : constant Name_Id := New_Internal_Name ('R'); - Predef_Prims : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => Name_Predef_Prims); + Iface_DT : constant Entity_Id := Make_Temporary (Loc, 'T'); + Predef_Prims : constant Entity_Id := Make_Temporary (Loc, 'R'); DT_Constr_List : List_Id; DT_Aggr_List : List_Id; Empty_DT : Boolean := False; @@ -3543,7 +3923,7 @@ package body Exp_Disp is -- Calculate the number of slots of the dispatch table. 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 + -- DT because at run time the pointer to this dummy entry will be -- used as the tag. if Num_Iface_Prims = 0 then @@ -3605,6 +3985,7 @@ package body Exp_Disp is if Is_Predefined_Dispatching_Operation (Prim) and then not Is_Abstract_Subprogram (Prim) + and then not Is_Eliminated (Prim) and then not Present (Prim_Table (UI_To_Int (DT_Position (Prim)))) then @@ -3613,11 +3994,8 @@ package body Exp_Disp is Alias (Prim); else - while Present (Alias (Prim)) loop - Prim := Alias (Prim); - end loop; - - Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); + Expand_Interface_Thunk + (Ultimate_Alias (Prim), Thunk_Id, Thunk_Code); if Present (Thunk_Id) then Append_To (Result, Thunk_Code); @@ -3655,10 +4033,8 @@ package body Exp_Disp is Decl := Make_Subtype_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')), - Subtype_Indication => + Defining_Identifier => Make_Temporary (Loc, 'S'), + Subtype_Indication => New_Reference_To (RTE (RE_Address_Array), Loc)); Append_To (Result, Decl); @@ -3786,12 +4162,7 @@ package body Exp_Disp is (Interface_Alias (Prim)) = Iface then Prim_Alias := Interface_Alias (Prim); - - E := Prim; - while Present (Alias (E)) loop - E := Alias (E); - end loop; - + E := Ultimate_Alias (Prim); Pos := UI_To_Int (DT_Position (Prim_Alias)); if Present (Prim_Table (Pos)) then @@ -3819,7 +4190,7 @@ package body Exp_Disp is pragma Assert (Count = Nb_Prim); end; - OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + OSD := Make_Temporary (Loc, 'I'); Append_To (Result, Make_Object_Declaration (Loc, @@ -3832,21 +4203,23 @@ package body Exp_Disp is Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( Make_Integer_Literal (Loc, Nb_Prim)))), - Expression => Make_Aggregate (Loc, - Component_Associations => New_List ( - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_OSD_Num_Prims), Loc)), - Expression => - Make_Integer_Literal (Loc, Nb_Prim)), - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_OSD_Table), Loc)), - Expression => Make_Aggregate (Loc, - Component_Associations => OSD_Aggr_List)))))); + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_OSD_Num_Prims), Loc)), + Expression => + Make_Integer_Literal (Loc, Nb_Prim)), + + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_OSD_Table), Loc)), + Expression => Make_Aggregate (Loc, + Component_Associations => OSD_Aggr_List)))))); Append_To (Result, Make_Attribute_Definition_Clause (Loc, @@ -3883,44 +4256,58 @@ package body Exp_Disp is else declare - Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; - Pos : Nat; - Thunk_Code : Node_Id; - Thunk_Id : Entity_Id; + CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ); + E : Entity_Id; + Prim_Pos : Nat; + Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; + Thunk_Code : Node_Id; + Thunk_Id : Entity_Id; begin Prim_Table := (others => Empty); Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop - Prim := Node (Prim_Elmt); + Prim := Node (Prim_Elmt); + E := Ultimate_Alias (Prim); + Prim_Pos := UI_To_Int (DT_Position (E)); + + -- Do not reference predefined primitives because they are + -- located in a separate dispatch table; skip abstract and + -- eliminated primitives; skip primitives located in the C++ + -- part of the dispatch table because their slot is set by + -- the IC routine. if not Is_Predefined_Dispatching_Operation (Prim) and then Present (Interface_Alias (Prim)) and then not Is_Abstract_Subprogram (Alias (Prim)) - and then not Is_Imported (Alias (Prim)) + and then not Is_Eliminated (Alias (Prim)) + and then (not Is_CPP_Class (Root_Type (Typ)) + or else Prim_Pos > CPP_Nb_Prims) and then Find_Dispatching_Type (Interface_Alias (Prim)) = Iface -- Generate the code of the thunk only if the abstract -- interface type is not an immediate ancestor of - -- Tagged_Type; otherwise the DT associated with the + -- Tagged_Type. Otherwise the DT associated with the -- interface is the primary DT. - and then not Is_Ancestor (Iface, Typ) + and then not Is_Ancestor (Iface, Typ, + Use_Full_View => True) then if not Build_Thunks then - Pos := + Prim_Pos := UI_To_Int (DT_Position (Interface_Alias (Prim))); - Prim_Table (Pos) := Alias (Prim); + Prim_Table (Prim_Pos) := Alias (Prim); + else Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); if Present (Thunk_Id) then - Pos := + Prim_Pos := UI_To_Int (DT_Position (Interface_Alias (Prim))); - Prim_Table (Pos) := Thunk_Id; + Prim_Table (Prim_Pos) := Thunk_Id; Append_To (Result, Thunk_Code); end if; end if; @@ -3936,6 +4323,7 @@ package body Exp_Disp is Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Prim_Table (J), Loc), Attribute_Name => Name_Unrestricted_Access)); + else New_Node := Make_Null (Loc); end if; @@ -4117,6 +4505,8 @@ package body Exp_Disp is if Has_Dispatch_Table (Typ) or else No (Access_Disp_Table (Typ)) or else Is_CPP_Class (Typ) + or else Convention (Typ) = Convention_CIL + or else Convention (Typ) = Convention_Java then return Result; @@ -4141,16 +4531,16 @@ package body Exp_Disp is end if; -- Ensure that the value of Max_Predef_Prims defined in a-tags is - -- correct. Valid values are 10 under configurable runtime or 16 + -- correct. Valid values are 9 under configurable runtime or 15 -- with full runtime. if RTE_Available (RE_Interface_Data) then - if Max_Predef_Prims /= 16 then + if Max_Predef_Prims /= 15 then Error_Msg_N ("run-time library configuration error", Typ); return Result; end if; else - if Max_Predef_Prims /= 10 then + if Max_Predef_Prims /= 9 then Error_Msg_N ("run-time library configuration error", Typ); Error_Msg_CRT ("tagged types", Typ); return Result; @@ -4173,9 +4563,7 @@ package body Exp_Disp is -- register the primitives in the slots will be generated later --- when -- each primitive is frozen (see Freeze_Subprogram). - if Building_Static_DT (Typ) - and then not Is_CPP_Class (Typ) - then + if Building_Static_DT (Typ) then declare Save : constant Boolean := Freezing_Library_Level_Tagged_Type; Prim : Entity_Id; @@ -4188,7 +4576,7 @@ package body Exp_Disp is Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); - Frnodes := Freeze_Entity (Prim, Loc); + Frnodes := Freeze_Entity (Prim, Typ); declare F : Entity_Id; @@ -4196,11 +4584,11 @@ package body Exp_Disp is begin F := First_Formal (Prim); while Present (F) loop - Check_Premature_Freezing (Prim, Etype (F)); + Check_Premature_Freezing (Prim, Typ, Etype (F)); Next_Formal (F); end loop; - Check_Premature_Freezing (Prim, Etype (Prim)); + Check_Premature_Freezing (Prim, Typ, Etype (Prim)); end; if Present (Frnodes) then @@ -4232,6 +4620,7 @@ package body Exp_Disp is AI_Tag_Comp := First_Elmt (Typ_Comps); while Present (AI_Tag_Comp) loop + pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'P')); -- Build the secondary table containing pointers to thunks @@ -4246,39 +4635,45 @@ package body Exp_Disp is Build_Thunks => True, Result => Result); - -- Skip secondary dispatch table and secondary dispatch table of - -- predefined primitives + -- Skip secondary dispatch table referencing thunks to predefined + -- primitives. Next_Elmt (AI_Tag_Elmt); + pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Y')); + + -- Secondary dispatch table referencing user-defined primitives + -- covered by this interface. + Next_Elmt (AI_Tag_Elmt); + pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'D')); -- Build the secondary table containing pointers to primitives -- (used to give support to Generic Dispatching Constructors). Make_Secondary_DT - (Typ => Typ, - Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))), - Suffix_Index => -1, - Num_Iface_Prims => UI_To_Int - (DT_Entry_Count (Node (AI_Tag_Comp))), - Iface_DT_Ptr => Node (AI_Tag_Elmt), - Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)), - Build_Thunks => False, - Result => Result); - - -- Skip secondary dispatch table and secondary dispatch table of - -- predefined primitives + (Typ => Typ, + Iface => Base_Type + (Related_Type (Node (AI_Tag_Comp))), + Suffix_Index => -1, + Num_Iface_Prims => UI_To_Int + (DT_Entry_Count (Node (AI_Tag_Comp))), + Iface_DT_Ptr => Node (AI_Tag_Elmt), + Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)), + Build_Thunks => False, + Result => Result); + + -- Skip secondary dispatch table referencing predefined primitives Next_Elmt (AI_Tag_Elmt); - Next_Elmt (AI_Tag_Elmt); + pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Z')); Suffix_Index := Suffix_Index + 1; + Next_Elmt (AI_Tag_Elmt); Next_Elmt (AI_Tag_Comp); end loop; end if; - -- Get the _tag entity and the number of primitives of its dispatch - -- table. + -- Get the _tag entity and number of primitives of its dispatch table DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); @@ -4311,17 +4706,6 @@ package body Exp_Disp is New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc))); - -- Generate a SCIL node for the previous object declaration - -- because it has a null dispatch table. - - if Generate_SCIL then - New_Node := - Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); - Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); - end if; - Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (DT, Loc), @@ -4348,15 +4732,17 @@ package body Exp_Disp is (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); + Set_Is_Statically_Allocated (DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); + -- Generate the SCIL node for the previous object declaration -- because it has a tag initialization. if Generate_SCIL then New_Node := Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); + Set_SCIL_Node (Last (Result), New_Node); end if; -- Generate: @@ -4388,17 +4774,6 @@ package body Exp_Disp is Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => DT_Constr_List)))); - -- Generate the SCIL node for the previous object declaration - -- because it contains a dispatch table. - - if Generate_SCIL then - New_Node := - Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); - Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); - end if; - Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (DT, Loc), @@ -4425,15 +4800,17 @@ package body Exp_Disp is (RTE_Record_Component (RE_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); + Set_Is_Statically_Allocated (DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); + -- Generate the SCIL node for the previous object declaration -- because it has a tag initialization. if Generate_SCIL then New_Node := Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); + Set_SCIL_Node (Last (Result), New_Node); end if; Append_To (Result, @@ -4466,7 +4843,7 @@ package body Exp_Disp is Object_Definition => New_Reference_To (Standard_String, Loc), Expression => Make_String_Literal (Loc, - Full_Qualified_Name (First_Subtype (Typ))))); + Fully_Qualified_Name_String (First_Subtype (Typ))))); Set_Is_Statically_Allocated (Exname); Set_Is_True_Constant (Exname); @@ -4487,13 +4864,15 @@ package body Exp_Disp is -- TSD : Type_Specific_Data (I_Depth) := -- (Idepth => I_Depth, -- Access_Level => Type_Access_Level (Typ), + -- Alignment => Typ'Alignment, -- Expanded_Name => Cstring_Ptr!(Exname'Address)) -- External_Tag => Cstring_Ptr!(Exname'Address)) -- HT_Link => HT_Link'Address, -- Transportable => <>, - -- RC_Offset => <>, - -- [ Size_Func => Size_Prim'Access ] - -- [ Interfaces_Table => <> ] + -- Type_Is_Abstract => <>, + -- Needs_Finalization => <>, + -- [ Size_Func => Size_Prim'Access, ] + -- [ Interfaces_Table => <>, ] -- [ SSD => SSD_Table'Address ] -- Tags_Table => (0 => null, -- 1 => Parent'Tag @@ -4535,12 +4914,29 @@ package body Exp_Disp is Append_To (TSD_Aggr_List, Make_Integer_Literal (Loc, Type_Access_Level (Typ))); + -- Alignment + + -- For CPP types we cannot rely on the value of 'Alignment provided + -- by the backend to initialize this TSD field. + + if Convention (Typ) = Convention_CPP + or else Is_CPP_Class (Root_Type (Typ)) + then + Append_To (TSD_Aggr_List, + Make_Integer_Literal (Loc, 0)); + else + Append_To (TSD_Aggr_List, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Typ, Loc), + Attribute_Name => Name_Alignment)); + end if; + -- Expanded_Name Append_To (TSD_Aggr_List, Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Exname, Loc), + Prefix => New_Reference_To (Exname, Loc), Attribute_Name => Name_Address))); -- External_Tag of a local tagged type @@ -4579,7 +4975,7 @@ package body Exp_Disp is New_External_Name (Tname, 'A')); Full_Name : constant String_Id := - Full_Qualified_Name (First_Subtype (Typ)); + Fully_Qualified_Name_String (First_Subtype (Typ)); Str1_Id : String_Id; Str2_Id : String_Id; @@ -4757,70 +5153,44 @@ package body Exp_Disp is New_Occurrence_Of (Transportable, Loc)); end; - -- RC_Offset: These are the valid values and their meaning: + -- Type_Is_Abstract (Ada 2012: AI05-0173). This functionality is + -- not available in the HIE runtime. - -- >0: For simple types with controlled components is - -- type._record_controller'position + if RTE_Record_Component_Available (RE_Type_Is_Abstract) then + declare + Type_Is_Abstract : Entity_Id; - -- 0: For types with no controlled components + begin + Type_Is_Abstract := + Boolean_Literals (Is_Abstract_Type (Typ)); - -- -1: For complex types with controlled components where the position - -- of the record controller is not statically computable but there - -- are controlled components at this level. The _Controller field - -- is available right after the _parent. + Append_To (TSD_Aggr_List, + New_Occurrence_Of (Type_Is_Abstract, Loc)); + end; + end if; - -- -2: There are no controlled components at this level. We need to - -- get the position from the parent. + -- Needs_Finalization: Set if the type is controlled or has controlled + -- components. declare - RC_Offset_Node : Node_Id; + Needs_Fin : Entity_Id; begin - if not Has_Controlled_Component (Typ) then - RC_Offset_Node := Make_Integer_Literal (Loc, 0); - - elsif Etype (Typ) /= Typ - and then Has_Discriminants (Parent_Typ) - then - if Has_New_Controlled_Component (Typ) then - RC_Offset_Node := Make_Integer_Literal (Loc, -1); - else - RC_Offset_Node := Make_Integer_Literal (Loc, -2); - end if; - else - RC_Offset_Node := - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => New_Reference_To (Typ, Loc), - Selector_Name => - New_Reference_To (Controller_Component (Typ), Loc)), - Attribute_Name => Name_Position); - - -- This is not proper Ada code to use the attribute 'Position - -- on something else than an object but this is supported by - -- the back end (see comment on the Bit_Component attribute in - -- sem_attr). So we avoid semantic checking here. - - -- Is this documented in sinfo.ads??? it should be! - - Set_Analyzed (RC_Offset_Node); - Set_Etype (Prefix (RC_Offset_Node), RTE (RE_Record_Controller)); - Set_Etype (Prefix (Prefix (RC_Offset_Node)), Typ); - Set_Etype (Selector_Name (Prefix (RC_Offset_Node)), - RTE (RE_Record_Controller)); - Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset)); - end if; - - Append_To (TSD_Aggr_List, RC_Offset_Node); + Needs_Fin := Boolean_Literals (Needs_Finalization (Typ)); + Append_To (TSD_Aggr_List, New_Occurrence_Of (Needs_Fin, Loc)); end; -- Size_Func if RTE_Record_Component_Available (RE_Size_Func) then - if not Building_Static_DT (Typ) - or else Is_Interface (Typ) - then + + -- Initialize this field to Null_Address if we are not building + -- static dispatch tables static or if the size function is not + -- available. In the former case we cannot initialize this field + -- until the function is frozen and registered in the dispatch + -- table (see Register_Primitive). + + if not Building_Static_DT (Typ) or else not Has_DT (Typ) then Append_To (TSD_Aggr_List, Unchecked_Convert_To (RTE (RE_Size_Ptr), New_Reference_To (RTE (RE_Null_Address), Loc))); @@ -4829,6 +5199,7 @@ package body Exp_Disp is declare Prim_Elmt : Elmt_Id; Prim : Entity_Id; + Size_Comp : Node_Id; begin Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); @@ -4836,20 +5207,18 @@ package body Exp_Disp is Prim := Node (Prim_Elmt); if Chars (Prim) = Name_uSize then - while Present (Alias (Prim)) loop - Prim := Alias (Prim); - end loop; + Prim := Ultimate_Alias (Prim); if Is_Abstract_Subprogram (Prim) then - Append_To (TSD_Aggr_List, + Size_Comp := Unchecked_Convert_To (RTE (RE_Size_Ptr), - New_Reference_To (RTE (RE_Null_Address), Loc))); + New_Reference_To (RTE (RE_Null_Address), Loc)); else - Append_To (TSD_Aggr_List, + Size_Comp := Unchecked_Convert_To (RTE (RE_Size_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Prim, Loc), - Attribute_Name => Name_Unrestricted_Access))); + Attribute_Name => Name_Unrestricted_Access)); end if; exit; @@ -4857,6 +5226,9 @@ package body Exp_Disp is Next_Elmt (Prim_Elmt); end loop; + + pragma Assert (Present (Size_Comp)); + Append_To (TSD_Aggr_List, Size_Comp); end; end if; end if; @@ -4889,7 +5261,7 @@ package body Exp_Disp is begin AI := First_Elmt (Typ_Ifaces); while Present (AI) loop - if Is_Ancestor (Node (AI), Typ) then + if Is_Ancestor (Node (AI), Typ, Use_Full_View => True) then Sec_DT_Tag := New_Reference_To (DT_Ptr, Loc); else @@ -4898,9 +5270,10 @@ package body Exp_Disp is (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); pragma Assert (Has_Thunks (Node (Elmt))); - while Ekind (Node (Elmt)) = E_Constant + while Is_Tag (Node (Elmt)) and then not - Is_Ancestor (Node (AI), Related_Type (Node (Elmt))) + Is_Ancestor (Node (AI), Related_Type (Node (Elmt)), + Use_Full_View => True) loop pragma Assert (Has_Thunks (Node (Elmt))); Next_Elmt (Elmt); @@ -4958,7 +5331,7 @@ package body Exp_Disp is Is_Library_Level_Tagged_Type (Typ)); -- The table of interfaces is not constant; its slots are - -- filled at run-time by the IP routine using attribute + -- filled at run time by the IP routine using attribute -- 'Position to know the location of the tag components -- (and this attribute cannot be safely used before the -- object is initialized). @@ -5008,7 +5381,7 @@ package body Exp_Disp is -- constrained by the number of non-predefined primitive operations. if RTE_Record_Component_Available (RE_SSD) then - if Ada_Version >= Ada_05 + if Ada_Version >= Ada_2005 and then Has_DT (Typ) and then Is_Concurrent_Record_Type (Typ) and then Has_Interfaces (Typ) @@ -5096,9 +5469,8 @@ package body Exp_Disp is exit when Parent_Typ = Current_Typ; - if Is_CPP_Class (Parent_Typ) - or else Is_Interface (Typ) - then + if Is_CPP_Class (Parent_Typ) then + -- The tags defined in the C++ side will be inherited when -- the object is constructed (Exp_Ch3.Build_Init_Procedure) @@ -5204,17 +5576,6 @@ package body Exp_Disp is Expression => Make_Aggregate (Loc, Expressions => DT_Aggr_List))); - -- Generate the SCIL node for the previous object declaration - -- because it has a null dispatch table. - - if Generate_SCIL then - New_Node := - Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); - Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); - end if; - Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (DT, Loc), @@ -5296,14 +5657,11 @@ package body Exp_Disp is if Is_Predefined_Dispatching_Operation (Prim) and then not Is_Abstract_Subprogram (Prim) + and then not Is_Eliminated (Prim) and then not Present (Prim_Table (UI_To_Int (DT_Position (Prim)))) then - E := Prim; - while Present (Alias (E)) loop - E := Alias (E); - end loop; - + E := Ultimate_Alias (Prim); pragma Assert (not Is_Abstract_Subprogram (E)); Prim_Table (UI_To_Int (DT_Position (Prim))) := E; end if; @@ -5332,10 +5690,8 @@ package body Exp_Disp is Decl := Make_Subtype_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')), - Subtype_Indication => + Defining_Identifier => Make_Temporary (Loc, 'S'), + Subtype_Indication => New_Reference_To (RTE (RE_Address_Array), Loc)); Append_To (Result, Decl); @@ -5427,10 +5783,12 @@ package body Exp_Disp is else declare - Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; - E : Entity_Id; - Prim : Entity_Id; - Prim_Elmt : Elmt_Id; + CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ); + E : Entity_Id; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + Prim_Pos : Nat; + Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; begin Prim_Table := (others => Empty); @@ -5442,25 +5800,29 @@ package body Exp_Disp is -- Retrieve the ultimate alias of the primitive for proper -- handling of renamings and eliminated primitives. - E := Ultimate_Alias (Prim); + E := Ultimate_Alias (Prim); + Prim_Pos := UI_To_Int (DT_Position (E)); - if Is_Imported (Prim) - or else Present (Interface_Alias (Prim)) - or else Is_Predefined_Dispatching_Operation (Prim) - or else Is_Eliminated (E) - then - null; + -- Do not reference predefined primitives because they are + -- located in a separate dispatch table; skip entities with + -- attribute Interface_Alias because they are only required + -- to build secondary dispatch tables; skip abstract and + -- eliminated primitives; for derivations of CPP types skip + -- primitives located in the C++ part of the dispatch table + -- because their slot is initialized by the IC routine. - else - if not Is_Predefined_Dispatching_Operation (E) - and then not Is_Abstract_Subprogram (E) - and then not Present (Interface_Alias (E)) - then - pragma Assert - (UI_To_Int (DT_Position (Prim)) <= Nb_Prim); + if not Is_Predefined_Dispatching_Operation (Prim) + and then not Is_Predefined_Dispatching_Operation (E) + and then not Present (Interface_Alias (Prim)) + and then not Is_Abstract_Subprogram (E) + and then not Is_Eliminated (E) + and then (not Is_CPP_Class (Root_Type (Typ)) + or else Prim_Pos > CPP_Nb_Prims) + then + pragma Assert + (UI_To_Int (DT_Position (Prim)) <= Nb_Prim); - Prim_Table (UI_To_Int (DT_Position (Prim))) := E; - end if; + Prim_Table (UI_To_Int (DT_Position (Prim))) := E; end if; Next_Elmt (Prim_Elmt); @@ -5521,17 +5883,6 @@ package body Exp_Disp is Expression => Make_Aggregate (Loc, Expressions => DT_Aggr_List))); - -- Generate the SCIL node for the previous object declaration - -- because it contains a dispatch table. - - if Generate_SCIL then - New_Node := - Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); - Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); - end if; - Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (DT, Loc), @@ -5808,6 +6159,36 @@ package body Exp_Disp is end if; end if; + -- If the type has a representation clause which specifies its external + -- tag then generate code to check if the external tag of this type is + -- the same as the external tag of some other declaration. + + -- Check_TSD (TSD'Unrestricted_Access); + + -- This check is a consequence of AI05-0113-1/06, so it officially + -- applies to Ada 2005 (and Ada 2012). It might be argued that it is + -- a desirable check to add in Ada 95 mode, but we hesitate to make + -- this change, as it would be incompatible, and could conceivably + -- cause a problem in existing Aa 95 code. + + -- We check for No_Run_Time_Mode here, because we do not want to pick + -- up the RE_Check_TSD entity and call it in No_Run_Time mode. + + if not No_Run_Time_Mode + and then Ada_Version >= Ada_2005 + and then Has_External_Tag_Rep_Clause (Typ) + and then RTE_Available (RE_Check_TSD) + and then not Debug_Flag_QQ + then + Append_To (Elab_Code, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Check_TSD), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (TSD, Loc), + Attribute_Name => Name_Unchecked_Access)))); + end if; + -- Generate code to register the Tag in the External_Tag hash table for -- the pure Ada type only. @@ -5840,7 +6221,7 @@ package body Exp_Disp is -- a limited interface. Skip this step in Ravenscar profile or when -- general dispatching is forbidden. - if Ada_Version >= Ada_05 + if Ada_Version >= Ada_2005 and then Is_Concurrent_Record_Type (Typ) and then Has_Interfaces (Typ) and then not Restriction_Active (No_Dispatching_Calls) @@ -5861,7 +6242,7 @@ package body Exp_Disp is -- Mark entities containing dispatch tables. Required by the backend to -- handle them properly. - if not Is_Interface (Typ) then + if Has_DT (Typ) then declare Elmt : Elmt_Id; @@ -5893,22 +6274,557 @@ package body Exp_Disp is end; end if; + -- Register the tagged type in the call graph nodes table + + Register_CG_Node (Typ); + return Result; end Make_DT; - ------------------------------------- - -- Make_Select_Specific_Data_Table -- - ------------------------------------- + ----------------- + -- Make_VM_TSD -- + ----------------- - function Make_Select_Specific_Data_Table - (Typ : Entity_Id) return List_Id - is - Assignments : constant List_Id := New_List; - Loc : constant Source_Ptr := Sloc (Typ); + function Make_VM_TSD (Typ : Entity_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (Typ); + Result : constant List_Id := New_List; - Conc_Typ : Entity_Id; + function Count_Primitives (Typ : Entity_Id) return Nat; + -- Count the non-predefined primitive operations of Typ + + ---------------------- + -- Count_Primitives -- + ---------------------- + + function Count_Primitives (Typ : Entity_Id) return Nat is + Nb_Prim : Nat; + Prim_Elmt : Elmt_Id; + Prim : Entity_Id; + + begin + Nb_Prim := 0; + + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Is_Predefined_Dispatching_Operation (Prim) + or else Is_Predefined_Dispatching_Alias (Prim) + then + null; + + elsif Present (Interface_Alias (Prim)) then + null; + + else + Nb_Prim := Nb_Prim + 1; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + return Nb_Prim; + end Count_Primitives; + + -------------- + -- Make_OSD -- + -------------- + + function Make_OSD (Iface : Entity_Id) return Node_Id; + -- Generate the Object Specific Data table required to dispatch calls + -- through synchronized interfaces. Returns a node that references the + -- generated OSD object. + + function Make_OSD (Iface : Entity_Id) return Node_Id is + Nb_Prim : constant Nat := Count_Primitives (Iface); + OSD : Entity_Id; + OSD_Aggr_List : List_Id; + + begin + -- Generate + -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) := + -- (OSD_Table => (1 => , + -- ... + -- N => )); + + if Nb_Prim = 0 + or else Is_Abstract_Type (Typ) + or else Is_Controlled (Typ) + or else Restriction_Active (No_Dispatching_Calls) + or else not Is_Limited_Type (Typ) + or else not Has_Interfaces (Typ) + or else not RTE_Record_Component_Available (RE_OSD_Table) + then + -- No OSD table required + + return Make_Null (Loc); + + else + OSD_Aggr_List := New_List; + + declare + Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; + Prim : Entity_Id; + Prim_Alias : Entity_Id; + Prim_Elmt : Elmt_Id; + E : Entity_Id; + Count : Nat := 0; + Pos : Nat; + + begin + Prim_Table := (others => Empty); + Prim_Alias := Empty; + + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Present (Interface_Alias (Prim)) + and then Find_Dispatching_Type + (Interface_Alias (Prim)) = Iface + then + Prim_Alias := Interface_Alias (Prim); + E := Ultimate_Alias (Prim); + Pos := UI_To_Int (DT_Position (Prim_Alias)); + + if Present (Prim_Table (Pos)) then + pragma Assert (Prim_Table (Pos) = E); + null; + + else + Prim_Table (Pos) := E; + + Append_To (OSD_Aggr_List, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, + DT_Position (Prim_Alias))), + Expression => + Make_Integer_Literal (Loc, + DT_Position (Alias (Prim))))); + + Count := Count + 1; + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + pragma Assert (Count = Nb_Prim); + end; + + OSD := Make_Temporary (Loc, 'I'); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => OSD, + Aliased_Present => True, + Constant_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Object_Specific_Data), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, Nb_Prim)))), + + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_OSD_Num_Prims), Loc)), + Expression => + Make_Integer_Literal (Loc, Nb_Prim)), + + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_OSD_Table), Loc)), + Expression => Make_Aggregate (Loc, + Component_Associations => OSD_Aggr_List)))))); + + return + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (OSD, Loc), + Attribute_Name => Name_Unchecked_Access); + end if; + end Make_OSD; + + -- Local variables + + Nb_Prim : constant Nat := Count_Primitives (Typ); + AI : Elmt_Id; + I_Depth : Nat; + Iface_Table_Node : Node_Id; + Num_Ifaces : Nat; + TSD_Aggr_List : List_Id; + Typ_Ifaces : Elist_Id; + TSD_Tags_List : List_Id; + + Tname : constant Name_Id := Chars (Typ); + Name_SSD : constant Name_Id := + New_External_Name (Tname, 'S', Suffix_Index => -1); + Name_TSD : constant Name_Id := + New_External_Name (Tname, 'B', Suffix_Index => -1); + SSD : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_SSD); + TSD : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_TSD); + begin + -- Generate code to create the storage for the type specific data object + -- with enough space to store the tags of the ancestors plus the tags + -- of all the implemented interfaces (as described in a-tags.ads). + + -- TSD : Type_Specific_Data (I_Depth) := + -- (Idepth => I_Depth, + -- Tag_Kind => , + -- Access_Level => Type_Access_Level (Typ), + -- Alignment => Typ'Alignment, + -- HT_Link => null, + -- Type_Is_Abstract => <>, + -- Type_Is_Library_Level => <>, + -- Interfaces_Table => <> + -- SSD => SSD_Table'Address + -- Tags_Table => (0 => Typ'Tag, + -- 1 => Parent'Tag + -- ...)); + + TSD_Aggr_List := New_List; + + -- Idepth: Count ancestors to compute the inheritance depth. For private + -- extensions, always go to the full view in order to compute the real + -- inheritance depth. + + declare + Current_Typ : Entity_Id; + Parent_Typ : Entity_Id; + + begin + I_Depth := 0; + Current_Typ := Typ; + loop + Parent_Typ := Etype (Current_Typ); + + if Is_Private_Type (Parent_Typ) then + Parent_Typ := Full_View (Base_Type (Parent_Typ)); + end if; + + exit when Parent_Typ = Current_Typ; + + I_Depth := I_Depth + 1; + Current_Typ := Parent_Typ; + end loop; + end; + + -- I_Depth + + Append_To (TSD_Aggr_List, + Make_Integer_Literal (Loc, I_Depth)); + + -- Tag_Kind + + Append_To (TSD_Aggr_List, Tagged_Kind (Typ)); + + -- Access_Level + + Append_To (TSD_Aggr_List, + Make_Integer_Literal (Loc, Type_Access_Level (Typ))); + + -- Alignment + + -- For CPP types we cannot rely on the value of 'Alignment provided + -- by the backend to initialize this TSD field. Why not??? + + if Convention (Typ) = Convention_CPP + or else Is_CPP_Class (Root_Type (Typ)) + then + Append_To (TSD_Aggr_List, + Make_Integer_Literal (Loc, 0)); + else + Append_To (TSD_Aggr_List, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Typ, Loc), + Attribute_Name => Name_Alignment)); + end if; + + -- HT_Link + + Append_To (TSD_Aggr_List, + Make_Null (Loc)); + + -- Type_Is_Abstract (Ada 2012: AI05-0173) + + declare + Type_Is_Abstract : Entity_Id; + + begin + Type_Is_Abstract := + Boolean_Literals (Is_Abstract_Type (Typ)); + + Append_To (TSD_Aggr_List, + New_Occurrence_Of (Type_Is_Abstract, Loc)); + end; + + -- Type_Is_Library_Level + + declare + Type_Is_Library_Level : Entity_Id; + begin + Type_Is_Library_Level := + Boolean_Literals (Is_Library_Level_Entity (Typ)); + Append_To (TSD_Aggr_List, + New_Occurrence_Of (Type_Is_Library_Level, Loc)); + end; + + -- Interfaces_Table (required for AI-405) + + if RTE_Record_Component_Available (RE_Interfaces_Table) then + + -- Count the number of interface types implemented by Typ + + Collect_Interfaces (Typ, Typ_Ifaces); + + Num_Ifaces := 0; + AI := First_Elmt (Typ_Ifaces); + while Present (AI) loop + Num_Ifaces := Num_Ifaces + 1; + Next_Elmt (AI); + end loop; + + if Num_Ifaces = 0 then + Iface_Table_Node := Make_Null (Loc); + + -- Generate the Interface_Table object + + else + declare + TSD_Ifaces_List : constant List_Id := New_List; + Iface : Entity_Id; + ITable : Node_Id; + + begin + AI := First_Elmt (Typ_Ifaces); + while Present (AI) loop + Iface := Node (AI); + + Append_To (TSD_Ifaces_List, + Make_Aggregate (Loc, + Expressions => New_List ( + + -- Iface_Tag + + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Iface, Loc), + Attribute_Name => Name_Tag), + + -- OSD + + Make_OSD (Iface)))); + + Next_Elmt (AI); + end loop; + + ITable := Make_Temporary (Loc, 'I'); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => ITable, + Aliased_Present => True, + Constant_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Interface_Data), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint + (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, Num_Ifaces)))), + + Expression => Make_Aggregate (Loc, + Expressions => New_List ( + Make_Integer_Literal (Loc, Num_Ifaces), + Make_Aggregate (Loc, + Expressions => TSD_Ifaces_List))))); + + Iface_Table_Node := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (ITable, Loc), + Attribute_Name => Name_Unchecked_Access); + end; + end if; + + Append_To (TSD_Aggr_List, Iface_Table_Node); + end if; + + -- Generate the Select Specific Data table for synchronized types that + -- implement synchronized interfaces. The size of the table is + -- constrained by the number of non-predefined primitive operations. + + if RTE_Record_Component_Available (RE_SSD) then + if Ada_Version >= Ada_2005 + and then Has_DT (Typ) + and then Is_Concurrent_Record_Type (Typ) + and then Has_Interfaces (Typ) + and then Nb_Prim > 0 + and then not Is_Abstract_Type (Typ) + and then not Is_Controlled (Typ) + and then not Restriction_Active (No_Dispatching_Calls) + and then not Restriction_Active (No_Select_Statements) + 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)))))); + + -- This table is initialized by Make_Select_Specific_Data_Table, + -- which calls Set_Entry_Index and Set_Prim_Op_Kind. + + Append_To (TSD_Aggr_List, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (SSD, Loc), + Attribute_Name => Name_Unchecked_Access)); + else + Append_To (TSD_Aggr_List, Make_Null (Loc)); + end if; + end if; + + -- Initialize the table of ancestor tags. In case of interface types + -- this table is not needed. + + TSD_Tags_List := New_List; + + -- Fill position 0 with Typ'Tag + + Append_To (TSD_Tags_List, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Typ, Loc), + Attribute_Name => Name_Tag)); + + -- Fill the rest of the table with the tags of the ancestors + + declare + Current_Typ : Entity_Id; + Parent_Typ : Entity_Id; + Pos : Nat; + + begin + Pos := 1; + Current_Typ := Typ; + + loop + Parent_Typ := Etype (Current_Typ); + + if Is_Private_Type (Parent_Typ) then + Parent_Typ := Full_View (Base_Type (Parent_Typ)); + end if; + + exit when Parent_Typ = Current_Typ; + + Append_To (TSD_Tags_List, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Parent_Typ, Loc), + Attribute_Name => Name_Tag)); + + Pos := Pos + 1; + Current_Typ := Parent_Typ; + end loop; + + pragma Assert (Pos = I_Depth + 1); + end; + + Append_To (TSD_Aggr_List, + Make_Aggregate (Loc, + Expressions => TSD_Tags_List)); + + -- Build the TSD object + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => TSD, + Aliased_Present => True, + Constant_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To ( + RTE (RE_Type_Specific_Data), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, I_Depth)))), + + Expression => Make_Aggregate (Loc, + Expressions => TSD_Aggr_List))); + + -- Generate: + -- Check_TSD + -- (TSD => TSD'Unrestricted_Access); + + if Ada_Version >= Ada_2005 + and then Is_Library_Level_Entity (Typ) + and then Has_External_Tag_Rep_Clause (Typ) + and then RTE_Available (RE_Check_TSD) + and then not Debug_Flag_QQ + then + Append_To (Result, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Check_TSD), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (TSD, Loc), + Attribute_Name => Name_Unrestricted_Access)))); + end if; + + -- Generate: + -- Register_TSD (TSD'Unrestricted_Access); + + Append_To (Result, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Register_TSD), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (TSD, Loc), + Attribute_Name => Name_Unrestricted_Access)))); + + -- Populate the two auxiliary tables used for dispatching asynchronous, + -- conditional and timed selects for synchronized types that implement + -- a limited interface. Skip this step in Ravenscar profile or when + -- general dispatching is forbidden. + + if Ada_Version >= Ada_2005 + and then Is_Concurrent_Record_Type (Typ) + and then Has_Interfaces (Typ) + and then not Restriction_Active (No_Dispatching_Calls) + and then not Restriction_Active (No_Select_Statements) + then + Append_List_To (Result, + Make_Select_Specific_Data_Table (Typ)); + end if; + + return Result; + end Make_VM_TSD; + + ------------------------------------- + -- Make_Select_Specific_Data_Table -- + ------------------------------------- + + function Make_Select_Specific_Data_Table + (Typ : Entity_Id) return List_Id + 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; @@ -5950,13 +6866,15 @@ package body Exp_Disp is return Uint_0; end Find_Entry_Index; + -- Local variables + + Tag_Node : Node_Id; + -- 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 Conc_Typ := Corresponding_Concurrent_Type (Typ); @@ -6000,6 +6918,10 @@ package body Exp_Disp is -- Look for primitive overriding an abstract interface subprogram if Present (Interface_Alias (Prim)) + and then not + Is_Ancestor + (Find_Dispatching_Type (Interface_Alias (Prim)), Typ, + Use_Full_View => True) and then not Examined (UI_To_Int (DT_Position (Alias (Prim)))) then Prim_Pos := DT_Position (Alias (Prim)); @@ -6010,20 +6932,29 @@ package body Exp_Disp is -- type. Generate: -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, , ); + if Tagged_Type_Expansion then + Tag_Node := + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Typ))), Loc); + + else + Tag_Node := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Typ, Loc), + Attribute_Name => Name_Tag); + end if; + Append_To (Assignments, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Set_Prim_Op_Kind), Loc), Parameter_Associations => New_List ( - New_Reference_To (DT_Ptr, Loc), + Tag_Node, Make_Integer_Literal (Loc, Prim_Pos), Prim_Op_Kind (Alias (Prim), Typ)))); -- Retrieve the root of the alias chain - Prim_Als := Prim; - while Present (Alias (Prim_Als)) loop - Prim_Als := Alias (Prim_Als); - end loop; + Prim_Als := Ultimate_Alias (Prim); -- In the case of an entry wrapper, set the entry index @@ -6035,12 +6966,23 @@ package body Exp_Disp is -- Ada.Tags.Set_Entry_Index -- (DT_Ptr, , ); + if Tagged_Type_Expansion then + Tag_Node := + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Typ))), Loc); + else + Tag_Node := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Typ, Loc), + Attribute_Name => Name_Tag); + end if; + Append_To (Assignments, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Set_Entry_Index), Loc), Parameter_Associations => New_List ( - New_Reference_To (DT_Ptr, Loc), + Tag_Node, Make_Integer_Literal (Loc, Prim_Pos), Make_Integer_Literal (Loc, Find_Entry_Index (Wrapped_Entity (Prim_Als)))))); @@ -6069,11 +7011,14 @@ package body Exp_Disp is -- Import the dispatch table DT of tagged type Tag_Typ. Required to -- generate forward references and statically allocate the table. For -- primary dispatch tables that require no dispatch table generate: + -- DT : static aliased constant Non_Dispatch_Table_Wrapper; - -- $pragma import (ada, DT); + -- pragma Import (Ada, DT); + -- Otherwise generate: + -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim); - -- $pragma import (ada, DT); + -- pragma Import (Ada, DT); --------------- -- Import_DT -- @@ -6098,8 +7043,7 @@ package body Exp_Disp is Get_External_Name (DT, True); Set_Interface_Name (DT, - Make_String_Literal (Loc, - Strval => String_From_Name_Buffer)); + Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); -- Ensure proper Sprint output of this implicit importation @@ -6111,9 +7055,7 @@ package body Exp_Disp is -- No dispatch table required - if not Is_Secondary_DT - and then not Has_DT (Tag_Typ) - then + if not Is_Secondary_DT and then not Has_DT (Tag_Typ) then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT, @@ -6129,8 +7071,8 @@ package body Exp_Disp is Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Tag_Typ))); - -- If the tagged type has no primitives we add a dummy slot - -- whose address will be the tag of this type. + -- If the tagged type has no primitives we add a dummy slot whose + -- address will be the tag of this type. if Nb_Prim = 0 then DT_Constr_List := @@ -6158,10 +7100,10 @@ package body Exp_Disp is Tname : constant Name_Id := Chars (Typ); AI_Tag_Comp : Elmt_Id; - DT : Node_Id; + DT : Node_Id := Empty; DT_Ptr : Node_Id; Predef_Prims_Ptr : Node_Id; - Iface_DT : Node_Id; + Iface_DT : Node_Id := Empty; Iface_DT_Ptr : Node_Id; New_Node : Node_Id; Suffix_Index : Int; @@ -6171,246 +7113,300 @@ package body Exp_Disp is -- Start of processing for Make_Tags begin - -- 1) Generate the primary and secondary tag entities - - -- Collect the components associated with secondary dispatch tables - - if Has_Interfaces (Typ) then - Collect_Interface_Components (Typ, Typ_Comps); - end if; + pragma Assert (No (Access_Disp_Table (Typ))); + Set_Access_Disp_Table (Typ, New_Elmt_List); -- 1) Generate the primary tag entities -- Primary dispatch table containing user-defined primitives - DT_Ptr := Make_Defining_Identifier (Loc, - New_External_Name (Tname, 'P')); - Set_Etype (DT_Ptr, RTE (RE_Tag)); - - -- Primary dispatch table containing predefined primitives - - Predef_Prims_Ptr := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Tname, 'Y')); - Set_Etype (Predef_Prims_Ptr, RTE (RE_Address)); - - -- Import the forward declaration of the Dispatch Table wrapper record - -- (Make_DT will take care of its exportation) + DT_Ptr := Make_Defining_Identifier (Loc, New_External_Name (Tname, 'P')); + Set_Etype (DT_Ptr, RTE (RE_Tag)); + Append_Elmt (DT_Ptr, Access_Disp_Table (Typ)); - if Building_Static_DT (Typ) then - Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List); + -- Minimum decoration - DT := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Tname, 'T')); + Set_Ekind (DT_Ptr, E_Variable); + Set_Related_Type (DT_Ptr, Typ); - Import_DT (Typ, DT, Is_Secondary_DT => False); + -- For CPP types there is no need to build the dispatch tables since + -- they are imported from the C++ side. If the CPP type has an IP then + -- we declare now the variable that will store the copy of the C++ tag. + -- If the CPP type is an interface, we need the variable as well because + -- it becomes the pointer to the corresponding secondary table. - if Has_DT (Typ) then + if Is_CPP_Class (Typ) then + if Has_CPP_Constructors (Typ) or else Is_Interface (Typ) then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT_Ptr, - Constant_Present => True, Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), Expression => Unchecked_Convert_To (RTE (RE_Tag), - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => New_Reference_To (DT, Loc), - Selector_Name => - New_Occurrence_Of - (RTE_Record_Component (RE_Prims_Ptr), Loc)), - Attribute_Name => Name_Address)))); + New_Reference_To (RTE (RE_Null_Address), Loc)))); - -- Generate the SCIL node for the previous object declaration - -- because it has a tag initialization. + Set_Is_Statically_Allocated (DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); + end if; - if Generate_SCIL then - New_Node := - Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); - Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); - end if; + -- Ada types - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => Predef_Prims_Ptr, - Constant_Present => True, - Object_Definition => New_Reference_To - (RTE (RE_Address), Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => New_Reference_To (DT, Loc), - Selector_Name => - New_Occurrence_Of - (RTE_Record_Component (RE_Predef_Prims), Loc)), - Attribute_Name => Name_Address))); + else + -- Primary dispatch table containing predefined primitives - -- No dispatch table required + Predef_Prims_Ptr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Tname, 'Y')); + Set_Etype (Predef_Prims_Ptr, RTE (RE_Address)); + Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ)); - else - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => DT_Ptr, - Constant_Present => True, - Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => New_Reference_To (DT, Loc), - Selector_Name => - New_Occurrence_Of - (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), - Attribute_Name => Name_Address)))); + -- Import the forward declaration of the Dispatch Table wrapper + -- record (Make_DT will take care of exporting it). - -- Generate the SCIL node for the previous object declaration - -- because it has a tag initialization. + if Building_Static_DT (Typ) then + Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List); - if Generate_SCIL then - New_Node := - Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); - Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); + DT := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Tname, 'T')); + + Import_DT (Typ, DT, Is_Secondary_DT => False); + + if Has_DT (Typ) then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT_Ptr, + Constant_Present => True, + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Prims_Ptr), Loc)), + Attribute_Name => Name_Address)))); + + -- Generate the SCIL node for the previous object declaration + -- because it has a tag initialization. + + if Generate_SCIL then + New_Node := + Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); + Set_SCIL_Entity (New_Node, Typ); + Set_SCIL_Node (Last (Result), New_Node); + end if; + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Predef_Prims_Ptr, + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Address), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Predef_Prims), Loc)), + Attribute_Name => Name_Address))); + + -- No dispatch table required + + else + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT_Ptr, + Constant_Present => True, + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_NDT_Prims_Ptr), + Loc)), + Attribute_Name => Name_Address)))); end if; - end if; - Set_Is_True_Constant (DT_Ptr); - Set_Is_Statically_Allocated (DT_Ptr); + Set_Is_True_Constant (DT_Ptr); + Set_Is_Statically_Allocated (DT_Ptr); + end if; end if; - pragma Assert (No (Access_Disp_Table (Typ))); - Set_Access_Disp_Table (Typ, New_Elmt_List); - Append_Elmt (DT_Ptr, Access_Disp_Table (Typ)); - Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ)); - -- 2) Generate the secondary tag entities + -- Collect the components associated with secondary dispatch tables + if Has_Interfaces (Typ) then + Collect_Interface_Components (Typ, Typ_Comps); - -- Note: The following value of Suffix_Index must be in sync with - -- the Suffix_Index values of secondary dispatch tables generated - -- by Make_DT. + -- For each interface type we build a unique external name associated + -- with its secondary dispatch table. This name is used to declare an + -- object that references this secondary dispatch table, whose value + -- will be used for the elaboration of Typ objects, and also for the + -- elaboration of objects of types derived from Typ that do not + -- override the primitives of this interface type. Suffix_Index := 1; - -- For each interface type we build an unique external name - -- associated with its corresponding secondary dispatch table. - -- This external name will be used to declare an object that - -- references this secondary dispatch table, value that will be - -- used for the elaboration of Typ's objects and also for the - -- elaboration of objects of derivations of Typ that do not - -- override the primitive operation of this interface type. + -- Note: The value of Suffix_Index must be in sync with the + -- Suffix_Index values of secondary dispatch tables generated + -- by Make_DT. - AI_Tag_Comp := First_Elmt (Typ_Comps); - while Present (AI_Tag_Comp) loop - Get_Secondary_DT_External_Name - (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index); - Typ_Name := Name_Find; + if Is_CPP_Class (Typ) then + AI_Tag_Comp := First_Elmt (Typ_Comps); + while Present (AI_Tag_Comp) loop + Get_Secondary_DT_External_Name + (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index); + Typ_Name := Name_Find; - if Building_Static_DT (Typ) then - Iface_DT := - Make_Defining_Identifier (Loc, - Chars => New_External_Name - (Typ_Name, 'T', Suffix_Index => -1)); - Import_DT - (Tag_Typ => Related_Type (Node (AI_Tag_Comp)), - DT => Iface_DT, - Is_Secondary_DT => True); - end if; + -- Declare variables that will store the copy of the C++ + -- secondary tags. - -- Secondary dispatch table referencing thunks to user-defined - -- primitives covered by this interface. + Iface_DT_Ptr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Typ_Name, 'P')); + Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); + Set_Ekind (Iface_DT_Ptr, E_Variable); + Set_Is_Tag (Iface_DT_Ptr); - Iface_DT_Ptr := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Typ_Name, 'P')); - Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); - Set_Ekind (Iface_DT_Ptr, E_Constant); - Set_Is_Tag (Iface_DT_Ptr); - Set_Has_Thunks (Iface_DT_Ptr); - Set_Is_Statically_Allocated (Iface_DT_Ptr, - Is_Library_Level_Tagged_Type (Typ)); - Set_Is_True_Constant (Iface_DT_Ptr); - Set_Related_Type - (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); - Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + Set_Has_Thunks (Iface_DT_Ptr); + Set_Related_Type + (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); + Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); - if Building_Static_DT (Typ) then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Iface_DT_Ptr, - Constant_Present => True, Object_Definition => New_Reference_To (RTE (RE_Interface_Tag), Loc), Expression => Unchecked_Convert_To (RTE (RE_Interface_Tag), - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => New_Reference_To (Iface_DT, Loc), - Selector_Name => - New_Occurrence_Of - (RTE_Record_Component (RE_Prims_Ptr), Loc)), - Attribute_Name => Name_Address)))); - end if; + New_Reference_To (RTE (RE_Null_Address), Loc)))); - -- Secondary dispatch table referencing thunks to predefined - -- primitives. + Set_Is_Statically_Allocated (Iface_DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); - Iface_DT_Ptr := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Typ_Name, 'Y')); - Set_Etype (Iface_DT_Ptr, RTE (RE_Address)); - Set_Ekind (Iface_DT_Ptr, E_Constant); - Set_Is_Tag (Iface_DT_Ptr); - Set_Has_Thunks (Iface_DT_Ptr); - Set_Is_Statically_Allocated (Iface_DT_Ptr, - Is_Library_Level_Tagged_Type (Typ)); - Set_Is_True_Constant (Iface_DT_Ptr); - Set_Related_Type - (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); - Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + Next_Elmt (AI_Tag_Comp); + end loop; - -- Secondary dispatch table referencing user-defined primitives - -- covered by this interface. + -- This is not a CPP_Class type - Iface_DT_Ptr := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Typ_Name, 'D')); - Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); - Set_Ekind (Iface_DT_Ptr, E_Constant); - Set_Is_Tag (Iface_DT_Ptr); - Set_Is_Statically_Allocated (Iface_DT_Ptr, - Is_Library_Level_Tagged_Type (Typ)); - Set_Is_True_Constant (Iface_DT_Ptr); - Set_Related_Type - (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); - Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + else + AI_Tag_Comp := First_Elmt (Typ_Comps); + while Present (AI_Tag_Comp) loop + Get_Secondary_DT_External_Name + (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index); + Typ_Name := Name_Find; + + if Building_Static_DT (Typ) then + Iface_DT := + Make_Defining_Identifier (Loc, + Chars => New_External_Name + (Typ_Name, 'T', Suffix_Index => -1)); + Import_DT + (Tag_Typ => Related_Type (Node (AI_Tag_Comp)), + DT => Iface_DT, + Is_Secondary_DT => True); + end if; - -- Secondary dispatch table referencing predefined primitives + -- Secondary dispatch table referencing thunks to user-defined + -- primitives covered by this interface. - Iface_DT_Ptr := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Typ_Name, 'Z')); - Set_Etype (Iface_DT_Ptr, RTE (RE_Address)); - Set_Ekind (Iface_DT_Ptr, E_Constant); - Set_Is_Tag (Iface_DT_Ptr); - Set_Is_Statically_Allocated (Iface_DT_Ptr, - Is_Library_Level_Tagged_Type (Typ)); - Set_Is_True_Constant (Iface_DT_Ptr); - Set_Related_Type - (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); - Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + Iface_DT_Ptr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Typ_Name, 'P')); + Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); + Set_Ekind (Iface_DT_Ptr, E_Constant); + Set_Is_Tag (Iface_DT_Ptr); + Set_Has_Thunks (Iface_DT_Ptr); + Set_Is_Statically_Allocated (Iface_DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); + Set_Is_True_Constant (Iface_DT_Ptr); + Set_Related_Type + (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); + Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); - Next_Elmt (AI_Tag_Comp); - end loop; + if Building_Static_DT (Typ) then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Iface_DT_Ptr, + Constant_Present => True, + Object_Definition => New_Reference_To + (RTE (RE_Interface_Tag), Loc), + Expression => + Unchecked_Convert_To (RTE (RE_Interface_Tag), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + New_Reference_To (Iface_DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Prims_Ptr), + Loc)), + Attribute_Name => Name_Address)))); + end if; + + -- Secondary dispatch table referencing thunks to predefined + -- primitives. + + Iface_DT_Ptr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Typ_Name, 'Y')); + Set_Etype (Iface_DT_Ptr, RTE (RE_Address)); + Set_Ekind (Iface_DT_Ptr, E_Constant); + Set_Is_Tag (Iface_DT_Ptr); + Set_Has_Thunks (Iface_DT_Ptr); + Set_Is_Statically_Allocated (Iface_DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); + Set_Is_True_Constant (Iface_DT_Ptr); + Set_Related_Type + (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); + Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + + -- Secondary dispatch table referencing user-defined primitives + -- covered by this interface. + + Iface_DT_Ptr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Typ_Name, 'D')); + Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); + Set_Ekind (Iface_DT_Ptr, E_Constant); + Set_Is_Tag (Iface_DT_Ptr); + Set_Is_Statically_Allocated (Iface_DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); + Set_Is_True_Constant (Iface_DT_Ptr); + Set_Related_Type + (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); + Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + + -- Secondary dispatch table referencing predefined primitives + + Iface_DT_Ptr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Typ_Name, 'Z')); + Set_Etype (Iface_DT_Ptr, RTE (RE_Address)); + Set_Ekind (Iface_DT_Ptr, E_Constant); + Set_Is_Tag (Iface_DT_Ptr); + Set_Is_Statically_Allocated (Iface_DT_Ptr, + Is_Library_Level_Tagged_Type (Typ)); + Set_Is_True_Constant (Iface_DT_Ptr); + Set_Related_Type + (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); + Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + + Next_Elmt (AI_Tag_Comp); + end loop; + end if; end if; -- 3) At the end of Access_Disp_Table, if the type has user-defined @@ -6470,7 +7466,22 @@ package body Exp_Disp is -- to simplify the expansion associated with dispatching calls. Analyze_List (Result); - Set_Suppress_Init_Proc (Base_Type (DT_Prims)); + Set_Suppress_Initialization (Base_Type (DT_Prims)); + + -- Disable backend optimizations based on assumptions about the + -- aliasing status of objects designated by the access to the + -- dispatch table. Required to handle dispatch tables imported + -- from C++. + + Set_No_Strict_Aliasing (Base_Type (DT_Prims_Acc)); + + -- Add the freezing nodes of these declarations; required to avoid + -- generating these freezing nodes in wrong scopes (for example in + -- the IC routine of a derivation of Typ). + -- What is an "IC routine"? Is "init_proc" meant here??? + + Append_List_To (Result, Freeze_Entity (DT_Prims, Typ)); + Append_List_To (Result, Freeze_Entity (DT_Prims_Acc, Typ)); -- Mark entity of dispatch table. Required by the back end to -- handle them properly. @@ -6479,7 +7490,25 @@ package body Exp_Disp is end; end if; - Set_Ekind (DT_Ptr, E_Constant); + -- Mark entities of dispatch table. Required by the back end to handle + -- them properly. + + if Present (DT) then + Set_Is_Dispatch_Table_Entity (DT); + Set_Is_Dispatch_Table_Entity (Etype (DT)); + end if; + + if Present (Iface_DT) then + Set_Is_Dispatch_Table_Entity (Iface_DT); + Set_Is_Dispatch_Table_Entity (Etype (Iface_DT)); + end if; + + if Is_CPP_Class (Root_Type (Typ)) then + Set_Ekind (DT_Ptr, E_Variable); + else + Set_Ekind (DT_Ptr, E_Constant); + end if; + Set_Is_Tag (DT_Ptr); Set_Related_Type (DT_Ptr, Typ); @@ -6542,10 +7571,7 @@ package body Exp_Disp is begin -- Retrieve the original primitive operation - Prim_Op := Prim; - while Present (Alias (Prim_Op)) loop - Prim_Op := Alias (Prim_Op); - end loop; + Prim_Op := Ultimate_Alias (Prim); if Ekind (Typ) = E_Record_Type and then Present (Corresponding_Concurrent_Type (Typ)) @@ -6642,8 +7668,13 @@ package body Exp_Disp is begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + pragma Assert (VM_Target = No_VM); - if not RTE_Available (RE_Tag) then + -- Do not register in the dispatch table eliminated primitives + + if not RTE_Available (RE_Tag) + or else Is_Eliminated (Ultimate_Alias (Prim)) + then return L; end if; @@ -6665,7 +7696,7 @@ package body Exp_Disp is Address_Node => Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Prim, Loc), + Prefix => New_Reference_To (Prim, Loc), Attribute_Name => Name_Unrestricted_Access)))); -- Register copy of the pointer to the 'size primitive in the TSD @@ -6683,17 +7714,24 @@ package body Exp_Disp is else pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); - DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ))); - Append_To (L, - Build_Set_Prim_Op_Address (Loc, - Typ => Tag_Typ, - Tag_Node => New_Reference_To (DT_Ptr, Loc), - Position => Pos, - Address_Node => - Unchecked_Convert_To (RTE (RE_Prim_Ptr), - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Prim, Loc), - Attribute_Name => Name_Unrestricted_Access)))); + -- Skip registration of primitives located in the C++ part of the + -- dispatch table. Their slot is set by the IC routine. + + if not Is_CPP_Class (Root_Type (Tag_Typ)) + or else Pos > CPP_Num_Prims (Tag_Typ) + then + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ))); + Append_To (L, + Build_Set_Prim_Op_Address (Loc, + Typ => Tag_Typ, + Tag_Node => New_Reference_To (DT_Ptr, Loc), + Position => Pos, + Address_Node => + Unchecked_Convert_To (RTE (RE_Prim_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Prim, Loc), + Attribute_Name => Name_Unrestricted_Access)))); + end if; end if; -- Ada 2005 (AI-251): Primitive associated with an interface type @@ -6708,9 +7746,26 @@ package body Exp_Disp is pragma Assert (Is_Interface (Iface_Typ)); + -- No action needed for interfaces that are ancestors of Typ because + -- their primitives are located in the primary dispatch table. + + if Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True) then + return L; + + -- No action needed for primitives located in the C++ part of the + -- dispatch table. Their slot is set by the IC routine. + + elsif Is_CPP_Class (Root_Type (Tag_Typ)) + and then DT_Position (Alias (Prim)) <= CPP_Num_Prims (Tag_Typ) + and then not Is_Predefined_Dispatching_Operation (Prim) + and then not Is_Predefined_Dispatching_Alias (Prim) + then + return L; + end if; + Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); - if not Is_Ancestor (Iface_Typ, Tag_Typ) + if not Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True) and then Present (Thunk_Code) then -- Generate the code necessary to fill the appropriate entry of @@ -6754,7 +7809,8 @@ package body Exp_Disp is Address_Node => Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Alias (Prim), Loc), + Prefix => + New_Reference_To (Alias (Prim), Loc), Attribute_Name => Name_Unrestricted_Access)))); else @@ -6785,7 +7841,8 @@ package body Exp_Disp is Address_Node => Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Alias (Prim), Loc), + Prefix => + New_Reference_To (Alias (Prim), Loc), Attribute_Name => Name_Unrestricted_Access)))); end if; @@ -6801,11 +7858,59 @@ package body Exp_Disp is procedure Set_All_DT_Position (Typ : Entity_Id) is + function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean; + -- Returns True if Prim is located in the dispatch table of + -- predefined primitives + procedure Validate_Position (Prim : Entity_Id); -- Check that the position assigned to Prim is completely safe -- (it has not been assigned to a previously defined primitive -- operation of Typ) + ------------------------ + -- In_Predef_Prims_DT -- + ------------------------ + + function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean is + E : Entity_Id; + + begin + -- Predefined primitives + + if Is_Predefined_Dispatching_Operation (Prim) then + return True; + + -- Renamings of predefined primitives + + elsif Present (Alias (Prim)) + and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim)) + then + if Chars (Ultimate_Alias (Prim)) /= Name_Op_Eq then + return True; + + -- User-defined renamings of predefined equality have their own + -- slot in the primary dispatch table + + else + E := Prim; + while Present (Alias (E)) loop + if Comes_From_Source (E) then + return False; + end if; + + E := Alias (E); + end loop; + + return not Comes_From_Source (E); + end if; + + -- User-defined primitives + + else + return False; + end if; + end In_Predef_Prims_DT; + ----------------------- -- Validate_Position -- ----------------------- @@ -6901,8 +8006,8 @@ package body Exp_Disp is First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ)); The_Tag : constant Entity_Id := First_Tag_Component (Typ); - Adjusted : Boolean := False; - Finalized : Boolean := False; + Adjusted : Boolean := False; + Finalized : Boolean := False; Count_Prim : Nat; DT_Length : Nat; @@ -6915,13 +8020,12 @@ package body Exp_Disp is begin pragma Assert (Present (First_Tag_Component (Typ))); - -- Set the DT_Position for each primitive operation. Perform some - -- sanity checks to avoid to build completely inconsistent dispatch - -- tables. + -- Set the DT_Position for each primitive operation. Perform some sanity + -- checks to avoid building inconsistent dispatch tables. - -- First stage: Set the DTC entity of all the primitive operations - -- This is required to properly read the DT_Position attribute in - -- the latter stages. + -- First stage: Set the DTC entity of all the primitive operations. This + -- is required to properly read the DT_Position attribute in the latter + -- stages. Prim_Elmt := First_Prim; Count_Prim := 0; @@ -6930,9 +8034,7 @@ package body Exp_Disp is -- Predefined primitives have a separate dispatch table - if not (Is_Predefined_Dispatching_Operation (Prim) - or else Is_Predefined_Dispatching_Alias (Prim)) - then + if not In_Predef_Prims_DT (Prim) then Count_Prim := Count_Prim + 1; end if; @@ -7042,7 +8144,7 @@ package body Exp_Disp is (Nkind (Parent (Typ)) = N_Private_Extension_Declaration and then Is_Generic_Type (Typ))) and then In_Open_Scopes (Scope (Etype (Typ))) - and then Typ = Base_Type (Typ) + and then Is_Base_Type (Typ) then Handle_Inherited_Private_Subprograms (Typ); end if; @@ -7057,22 +8159,21 @@ package body Exp_Disp is -- 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)); - - elsif Is_Predefined_Dispatching_Alias (Prim) then - E := Alias (Prim); - while Present (Alias (E)) loop - E := Alias (E); - end loop; + if In_Predef_Prims_DT (Prim) then + if Is_Predefined_Dispatching_Operation (Prim) then + Set_DT_Position (Prim, Default_Prim_Op_Position (Prim)); - Set_DT_Position (Prim, Default_Prim_Op_Position (E)); + else pragma Assert (Present (Alias (Prim))); + Set_DT_Position (Prim, + Default_Prim_Op_Position (Ultimate_Alias (Prim))); + end if; -- Overriding primitives of ancestor abstract interfaces elsif Present (Interface_Alias (Prim)) and then Is_Ancestor - (Find_Dispatching_Type (Interface_Alias (Prim)), Typ) + (Find_Dispatching_Type (Interface_Alias (Prim)), Typ, + Use_Full_View => True) then pragma Assert (DT_Position (Prim) = No_Uint and then Present (DTC_Entity (Interface_Alias (Prim)))); @@ -7094,7 +8195,8 @@ package body Exp_Disp is and then Chars (Prim) = Chars (Alias (Prim)) and then Find_Dispatching_Type (Alias (Prim)) /= Typ and then Is_Ancestor - (Find_Dispatching_Type (Alias (Prim)), Typ) + (Find_Dispatching_Type (Alias (Prim)), Typ, + Use_Full_View => True) and then Present (DTC_Entity (Alias (Prim))) then E := Alias (Prim); @@ -7108,7 +8210,7 @@ package body Exp_Disp is Next_Elmt (Prim_Elmt); end loop; - -- Third stage: Fix the position of all the new primitives + -- Third stage: Fix the position of all the new primitives. -- Entries associated with primitives covering interfaces -- are handled in a latter round. @@ -7160,7 +8262,8 @@ package body Exp_Disp is -- Check if this entry will be placed in the primary DT if Is_Ancestor - (Find_Dispatching_Type (Interface_Alias (Prim)), Typ) + (Find_Dispatching_Type (Interface_Alias (Prim)), Typ, + Use_Full_View => True) then pragma Assert (DT_Position (Alias (Prim)) /= No_Uint); Set_DT_Position (Prim, DT_Position (Alias (Prim))); @@ -7204,8 +8307,7 @@ package body Exp_Disp is -- Calculate real size of the dispatch table - if not (Is_Predefined_Dispatching_Operation (Prim) - or else Is_Predefined_Dispatching_Alias (Prim)) + if not In_Predef_Prims_DT (Prim) and then UI_To_Int (DT_Position (Prim)) > DT_Length then DT_Length := UI_To_Int (DT_Position (Prim)); @@ -7214,8 +8316,8 @@ package body Exp_Disp is -- Ensure that the assigned position to non-predefined -- dispatching operations in the dispatch table is correct. - if not (Is_Predefined_Dispatching_Operation (Prim) - or else Is_Predefined_Dispatching_Alias (Prim)) + if not Is_Predefined_Dispatching_Operation (Prim) + and then not Is_Predefined_Dispatching_Alias (Prim) then Validate_Position (Prim); end if; @@ -7228,17 +8330,21 @@ package body Exp_Disp is Adjusted := True; end if; - -- An abstract operation cannot be declared in the private part - -- for a visible abstract type, because it could never be over- - -- ridden. For explicit declarations this is checked at the - -- point of declaration, but for inherited operations it must - -- be done when building the dispatch table. + -- An abstract operation cannot be declared in the private part for a + -- visible abstract type, because it can't be overridden outside this + -- package hierarchy. For explicit declarations this is checked at + -- the point of declaration, but for inherited operations it must be + -- done when building the dispatch table. -- Ada 2005 (AI-251): Primitives associated with interfaces are -- excluded from this check because interfaces must be visible in -- the public and private part (RM 7.3 (7.3/2)) - if Is_Abstract_Type (Typ) + -- We disable this check in CodePeer mode, to accommodate legacy + -- Ada code. + + if not CodePeer_Mode + and then Is_Abstract_Type (Typ) and then Is_Abstract_Subprogram (Prim) and then Present (Alias (Prim)) and then not Is_Interface @@ -7303,14 +8409,116 @@ package body Exp_Disp is -------------------------- procedure Set_CPP_Constructors (Typ : Entity_Id) is + + procedure Set_CPP_Constructors_Old (Typ : Entity_Id); + -- For backward compatibility this routine handles CPP constructors + -- of non-tagged types. + + procedure Set_CPP_Constructors_Old (Typ : Entity_Id) is + Loc : Source_Ptr; + Init : Entity_Id; + E : Entity_Id; + Found : Boolean := False; + P : Node_Id; + Parms : List_Id; + + begin + -- Look for the constructor entities + + E := Next_Entity (Typ); + while Present (E) loop + if Ekind (E) = E_Function + and then Is_Constructor (E) + then + -- Create the init procedure + + Found := True; + Loc := Sloc (E); + Init := Make_Defining_Identifier (Loc, + Make_Init_Proc_Name (Typ)); + Parms := + New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_X), + Parameter_Type => + New_Reference_To (Typ, Loc))); + + if Present (Parameter_Specifications (Parent (E))) then + P := First (Parameter_Specifications (Parent (E))); + while Present (P) loop + Append_To (Parms, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars (Defining_Identifier (P))), + Parameter_Type => + New_Copy_Tree (Parameter_Type (P)))); + Next (P); + end loop; + end if; + + Discard_Node ( + Make_Subprogram_Declaration (Loc, + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Init, + Parameter_Specifications => Parms))); + + Set_Init_Proc (Typ, Init); + Set_Is_Imported (Init); + Set_Is_Constructor (Init); + Set_Interface_Name (Init, Interface_Name (E)); + Set_Convention (Init, Convention_CPP); + Set_Is_Public (Init); + Set_Has_Completion (Init); + end if; + + Next_Entity (E); + end loop; + + -- If there are no constructors, mark the type as abstract since we + -- won't be able to declare objects of that type. + + if not Found then + Set_Is_Abstract_Type (Typ); + end if; + end Set_CPP_Constructors_Old; + + -- Local variables + Loc : Source_Ptr; - Init : Entity_Id; E : Entity_Id; Found : Boolean := False; P : Node_Id; Parms : List_Id; + Constructor_Decl_Node : Node_Id; + Constructor_Id : Entity_Id; + Wrapper_Id : Entity_Id; + Wrapper_Body_Node : Node_Id; + Actuals : List_Id; + Body_Stmts : List_Id; + Init_Tags_List : List_Id; + begin + pragma Assert (Is_CPP_Class (Typ)); + + -- For backward compatibility the compiler accepts C++ classes + -- imported through non-tagged record types. In such case the + -- wrapper of the C++ constructor is useless because the _tag + -- component is not available. + + -- Example: + -- type Root is limited record ... + -- pragma Import (CPP, Root); + -- function New_Root return Root; + -- pragma CPP_Constructor (New_Root, ... ); + + if not Is_Tagged_Type (Typ) then + Set_CPP_Constructors_Old (Typ); + return; + end if; + -- Look for the constructor entities E := Next_Entity (Typ); @@ -7318,16 +8526,16 @@ package body Exp_Disp is if Ekind (E) = E_Function and then Is_Constructor (E) then - -- Create the init procedure - Found := True; Loc := Sloc (E); - Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ)); + + -- Generate the declaration of the imported C++ constructor + Parms := New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => - Make_Defining_Identifier (Loc, Name_X), + Make_Defining_Identifier (Loc, Name_uInit), Parameter_Type => New_Reference_To (Typ, Loc))); @@ -7344,18 +8552,130 @@ package body Exp_Disp is end loop; end if; - Discard_Node ( + Constructor_Id := Make_Temporary (Loc, 'P'); + + Constructor_Decl_Node := Make_Subprogram_Declaration (Loc, Make_Procedure_Specification (Loc, - Defining_Unit_Name => Init, - Parameter_Specifications => Parms))); - - Set_Init_Proc (Typ, Init); - Set_Is_Imported (Init); - Set_Interface_Name (Init, Interface_Name (E)); - Set_Convention (Init, Convention_C); - Set_Is_Public (Init); - Set_Has_Completion (Init); + Defining_Unit_Name => Constructor_Id, + Parameter_Specifications => Parms)); + + Set_Is_Imported (Constructor_Id); + Set_Is_Constructor (Constructor_Id); + Set_Interface_Name (Constructor_Id, Interface_Name (E)); + Set_Convention (Constructor_Id, Convention_CPP); + Set_Is_Public (Constructor_Id); + Set_Has_Completion (Constructor_Id); + + -- Build the wrapper of this constructor + + Parms := + New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uInit), + Parameter_Type => + New_Reference_To (Typ, Loc))); + + if Present (Parameter_Specifications (Parent (E))) then + P := First (Parameter_Specifications (Parent (E))); + while Present (P) loop + Append_To (Parms, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars (Defining_Identifier (P))), + Parameter_Type => New_Copy_Tree (Parameter_Type (P)))); + Next (P); + end loop; + end if; + + Body_Stmts := New_List; + + -- Invoke the C++ constructor + + Actuals := New_List; + + P := First (Parms); + while Present (P) loop + Append_To (Actuals, + New_Reference_To (Defining_Identifier (P), Loc)); + Next (P); + end loop; + + Append_To (Body_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Constructor_Id, Loc), + Parameter_Associations => Actuals)); + + -- Initialize copies of C++ primary and secondary tags + + Init_Tags_List := New_List; + + declare + Tag_Elmt : Elmt_Id; + Tag_Comp : Node_Id; + + begin + Tag_Elmt := First_Elmt (Access_Disp_Table (Typ)); + Tag_Comp := First_Tag_Component (Typ); + + while Present (Tag_Elmt) + and then Is_Tag (Node (Tag_Elmt)) + loop + -- Skip the following assertion with primary tags because + -- Related_Type is not set on primary tag components + + pragma Assert (Tag_Comp = First_Tag_Component (Typ) + or else Related_Type (Node (Tag_Elmt)) + = Related_Type (Tag_Comp)); + + Append_To (Init_Tags_List, + Make_Assignment_Statement (Loc, + Name => + New_Reference_To (Node (Tag_Elmt), Loc), + Expression => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uInit), + Selector_Name => + New_Reference_To (Tag_Comp, Loc)))); + + Tag_Comp := Next_Tag_Component (Tag_Comp); + Next_Elmt (Tag_Elmt); + end loop; + end; + + Append_To (Body_Stmts, + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Typ))), + Loc), + Right_Opnd => + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (RTE (RE_Null_Address), Loc))), + Then_Statements => Init_Tags_List)); + + Wrapper_Id := Make_Defining_Identifier (Loc, + Make_Init_Proc_Name (Typ)); + + Wrapper_Body_Node := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Wrapper_Id, + Parameter_Specifications => Parms), + Declarations => New_List (Constructor_Decl_Node), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Body_Stmts, + Exception_Handlers => No_List)); + + Discard_Node (Wrapper_Body_Node); + Set_Init_Proc (Typ, Wrapper_Id); end if; Next_Entity (E); @@ -7367,6 +8687,17 @@ package body Exp_Disp is if not Found then Set_Is_Abstract_Type (Typ); end if; + + -- If the CPP type has constructors then it must import also the default + -- C++ constructor. It is required for default initialization of objects + -- of the type. It is also required to elaborate objects of Ada types + -- that are defined as derivations of this CPP type. + + if Has_CPP_Constructors (Typ) + and then No (Init_Proc (Typ)) + then + Error_Msg_N ("?default constructor must be imported from C++", Typ); + end if; end Set_CPP_Constructors; -------------------------- @@ -7496,6 +8827,17 @@ package body Exp_Disp is Write_Str ("(predefined) "); end if; + -- Prefix the name of the primitive with its corresponding tagged + -- type to facilitate seeing inherited primitives. + + if Present (Alias (Prim)) then + Write_Name + (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim)))); + else + Write_Name (Chars (Typ)); + end if; + + Write_Str ("."); Write_Name (Chars (Prim)); -- Indicate if this primitive has an aliased primitive @@ -7505,7 +8847,7 @@ package body Exp_Disp is Write_Int (Int (Alias (Prim))); -- If the DTC_Entity attribute is already set we can also output - -- the name of the interface covered by this primitive (if any) + -- the name of the interface covered by this primitive (if any). if Present (DTC_Entity (Alias (Prim))) and then Is_Interface (Scope (DTC_Entity (Alias (Prim)))) @@ -7516,6 +8858,11 @@ package body Exp_Disp is if Present (Interface_Alias (Prim)) then Write_Str (", AI_Alias of "); + + if Is_Null_Interface_Primitive (Interface_Alias (Prim)) then + Write_Str ("null primitive "); + end if; + Write_Name (Chars (Find_Dispatching_Type (Interface_Alias (Prim)))); Write_Char (':'); @@ -7551,6 +8898,12 @@ package body Exp_Disp is Write_Str (" (eliminated)"); end if; + if Is_Imported (Prim) + and then Convention (Prim) = Convention_CPP + then + Write_Str (" (C++)"); + end if; + Write_Eol; Next_Elmt (Elmt);