X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fexp_disp.adb;h=b7f31c36c4aeb3b9a0a222bb0a9c0a1cab09cf20;hb=afb3d3c49fad6249e0b85722105326e9031d9475;hp=860fd17352cc90d5683cb588d6591debfdc7469b;hpb=a652dd51177b2a20126b73ecf4e00d011c8ac503;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 860fd17352c..b7f31c36c4a 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, 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- -- @@ -36,6 +36,7 @@ with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Itypes; use Itypes; +with Layout; use Layout; with Nlists; use Nlists; with Nmake; use Nmake; with Namet; use Namet; @@ -45,6 +46,7 @@ with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Aux; use Sem_Aux; with Sem_Ch6; use Sem_Ch6; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; @@ -57,7 +59,6 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -79,6 +80,11 @@ package body Exp_Disp is -- Returns true if Prim is not a predefined dispatching primitive but it is -- an alias of a predefined dispatching primitive (i.e. through a renaming) + function New_Value (From : Node_Id) return Node_Id; + -- From is the original Expression. New_Value is equivalent to a call + -- to Duplicate_Subexpr with an explicit dereference when From is an + -- access parameter. + function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean; -- Check if the type has a private view or if the public view appears -- in the visible part of a package spec. @@ -94,6 +100,182 @@ package body Exp_Disp is -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference -- to an RE_Tagged_Kind enumeration value. + ---------------------- + -- Apply_Tag_Checks -- + ---------------------- + + procedure Apply_Tag_Checks (Call_Node : Node_Id) is + Loc : constant Source_Ptr := Sloc (Call_Node); + Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node); + Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg)); + Param_List : constant List_Id := Parameter_Associations (Call_Node); + + Subp : Entity_Id; + CW_Typ : Entity_Id; + Param : Node_Id; + Typ : Entity_Id; + Eq_Prim_Op : Entity_Id := Empty; + + begin + if No_Run_Time_Mode then + Error_Msg_CRT ("tagged types", Call_Node); + return; + end if; + + -- Apply_Tag_Checks 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 when 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; + end if; + + -- Set subprogram. If this is an inherited operation that was + -- overridden, the body that is being called is its alias. + + Subp := Entity (Name (Call_Node)); + + if Present (Alias (Subp)) + and then Is_Inherited_Operation (Subp) + and then No (DTC_Entity (Subp)) + then + Subp := Alias (Subp); + end if; + + -- Definition of the class-wide type and the tagged type + + -- If the controlling argument is itself a tag rather than a tagged + -- object, then use the class-wide type associated with the subprogram's + -- controlling type. This case can occur when a call to an inherited + -- primitive has an actual that originated from a default parameter + -- given by a tag-indeterminate call and when there is no other + -- controlling argument providing the tag (AI-239 requires dispatching). + -- This capability of dispatching directly by tag is also needed by the + -- implementation of AI-260 (for the generic dispatching constructors). + + if Ctrl_Typ = RTE (RE_Tag) + or else (RTE_Available (RE_Interface_Tag) + and then Ctrl_Typ = RTE (RE_Interface_Tag)) + then + CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp)); + + -- Class_Wide_Type is applied to the expressions used to initialize + -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since + -- there are cases where the controlling type is resolved to a specific + -- type (such as for designated types of arguments such as CW'Access). + + elsif Is_Access_Type (Ctrl_Typ) then + CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ)); + + else + 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; + + if not Is_Limited_Type (Typ) then + Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); + end if; + + -- Dispatching call to C++ primitive + + if Is_CPP_Class (Typ) then + null; + + -- Dispatching call to Ada primitive + + elsif Present (Param_List) then + + -- Generate the Tag checks when appropriate + + Param := First_Actual (Call_Node); + while Present (Param) loop + + -- No tag check with itself + + if Param = Ctrl_Arg then + null; + + -- No tag check for parameter whose type is neither tagged nor + -- access to tagged (for access parameters) + + elsif No (Find_Controlling_Arg (Param)) then + null; + + -- No tag check for function dispatching on result if the + -- Tag given by the context is this one + + elsif Find_Controlling_Arg (Param) = Ctrl_Arg then + null; + + -- "=" is the only dispatching operation allowed to get + -- operands with incompatible tags (it just returns false). + -- We use Duplicate_Subexpr_Move_Checks instead of calling + -- Relocate_Node because the value will be duplicated to + -- check the tags. + + elsif Subp = Eq_Prim_Op then + null; + + -- No check in presence of suppress flags + + elsif Tag_Checks_Suppressed (Etype (Param)) + or else (Is_Access_Type (Etype (Param)) + and then Tag_Checks_Suppressed + (Designated_Type (Etype (Param)))) + then + null; + + -- Optimization: no tag checks if the parameters are identical + + elsif Is_Entity_Name (Param) + and then Is_Entity_Name (Ctrl_Arg) + and then Entity (Param) = Entity (Ctrl_Arg) + then + null; + + -- Now we need to generate the Tag check + + else + -- Generate code for tag equality check + -- Perhaps should have Checks.Apply_Tag_Equality_Check??? + + Insert_Action (Ctrl_Arg, + Make_Implicit_If_Statement (Call_Node, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Value (Ctrl_Arg), + Selector_Name => + New_Reference_To + (First_Tag_Component (Typ), Loc)), + + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Typ, New_Value (Param)), + Selector_Name => + New_Reference_To + (First_Tag_Component (Typ), Loc))), + + Then_Statements => + New_List (New_Constraint_Error (Loc)))); + end if; + + Next_Actual (Param); + end loop; + end if; + end Apply_Tag_Checks; + ------------------------ -- Building_Static_DT -- ------------------------ @@ -162,36 +344,56 @@ package body Exp_Disp is -- Handle full type declarations and derivations of library -- level tagged types - elsif (Nkind (D) = N_Full_Type_Declaration - or else Nkind (D) = N_Derived_Type_Definition) + elsif Nkind_In (D, N_Full_Type_Declaration, + N_Derived_Type_Definition) and then Is_Library_Level_Tagged_Type (Defining_Entity (D)) and then Ekind (Defining_Entity (D)) /= E_Record_Subtype and then not Is_Private_Type (Defining_Entity (D)) then - Insert_List_After_And_Analyze (Last (Target_List), - Make_DT (Defining_Entity (D))); + -- We do not generate dispatch tables for the internal types + -- created for a type extension with unknown discriminants + -- The needed information is shared with the source type, + -- See Expand_N_Record_Extension. + + if Is_Underlying_Record_View (Defining_Entity (D)) + or else + (not Comes_From_Source (Defining_Entity (D)) + and then + Has_Unknown_Discriminants (Etype (Defining_Entity (D))) + and then + not Comes_From_Source + (First_Subtype (Defining_Entity (D)))) + then + null; + else + Insert_List_After_And_Analyze (Last (Target_List), + Make_DT (Defining_Entity (D))); + end if; -- Handle private types of library level tagged types. We must -- exchange the private and full-view to ensure the correct - -- expansion. + -- expansion. If the full view is a synchronized type ignore + -- the type because the table will be built for the corresponding + -- record type, that has its own declaration. elsif (Nkind (D) = N_Private_Type_Declaration or else Nkind (D) = N_Private_Extension_Declaration) and then Present (Full_View (Defining_Entity (D))) - and then Is_Library_Level_Tagged_Type - (Full_View (Defining_Entity (D))) - and then Ekind (Full_View (Defining_Entity (D))) - /= E_Record_Subtype then declare E1 : constant Entity_Id := Defining_Entity (D); - E2 : constant Entity_Id := Full_View (Defining_Entity (D)); + E2 : constant Entity_Id := Full_View (E1); begin - Exchange_Declarations (E1); - Insert_List_After_And_Analyze (Last (Target_List), - Make_DT (E1)); - Exchange_Declarations (E2); + if Is_Library_Level_Tagged_Type (E2) + and then Ekind (E2) /= E_Record_Subtype + and then not Is_Concurrent_Type (E2) + then + Exchange_Declarations (E1); + Insert_List_After_And_Analyze (Last (Target_List), + Make_DT (E1)); + Exchange_Declarations (E2); + end if; end; end if; @@ -227,7 +429,7 @@ package body Exp_Disp is begin if not Expander_Active - or else VM_Target /= No_VM + or else not Tagged_Type_Expansion then return; end if; @@ -373,6 +575,11 @@ package body Exp_Disp is end if; end New_Value; + -- Local variables + + New_Node : Node_Id; + SCIL_Node : Node_Id; + -- Start of processing for Expand_Dispatching_Call begin @@ -441,6 +648,19 @@ package body Exp_Disp is 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; + if not Is_Limited_Type (Typ) then Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); end if; @@ -448,8 +668,9 @@ package body Exp_Disp is -- Dispatching call to C++ primitive. Create a new parameter list -- with no tag checks. + New_Params := New_List; + if Is_CPP_Class (Typ) then - New_Params := New_List; Param := First_Actual (Call_Node); while Present (Param) loop Append_To (New_Params, Relocate_Node (Param)); @@ -459,87 +680,22 @@ package body Exp_Disp is -- Dispatching call to Ada primitive elsif Present (Param_List) then + Apply_Tag_Checks (Call_Node); - -- Generate the Tag checks when appropriate - - New_Params := New_List; Param := First_Actual (Call_Node); while Present (Param) loop + -- Cases in which we may have generated runtime checks - -- No tag check with itself - - if Param = Ctrl_Arg then - Append_To (New_Params, - Duplicate_Subexpr_Move_Checks (Param)); - - -- No tag check for parameter whose type is neither tagged nor - -- access to tagged (for access parameters) - - elsif No (Find_Controlling_Arg (Param)) then - Append_To (New_Params, Relocate_Node (Param)); - - -- No tag check for function dispatching on result if the - -- Tag given by the context is this one - - elsif Find_Controlling_Arg (Param) = Ctrl_Arg then - Append_To (New_Params, Relocate_Node (Param)); - - -- "=" is the only dispatching operation allowed to get - -- operands with incompatible tags (it just returns false). - -- We use Duplicate_Subexpr_Move_Checks instead of calling - -- Relocate_Node because the value will be duplicated to - -- check the tags. - - elsif Subp = Eq_Prim_Op then + if Param = Ctrl_Arg + or else Subp = Eq_Prim_Op + then Append_To (New_Params, Duplicate_Subexpr_Move_Checks (Param)); - -- No check in presence of suppress flags - - elsif Tag_Checks_Suppressed (Etype (Param)) - or else (Is_Access_Type (Etype (Param)) - and then Tag_Checks_Suppressed - (Designated_Type (Etype (Param)))) - then - Append_To (New_Params, Relocate_Node (Param)); - - -- Optimization: no tag checks if the parameters are identical - - elsif Is_Entity_Name (Param) - and then Is_Entity_Name (Ctrl_Arg) - and then Entity (Param) = Entity (Ctrl_Arg) + elsif Nkind (Parent (Param)) /= N_Parameter_Association + or else not Is_Accessibility_Actual (Parent (Param)) then Append_To (New_Params, Relocate_Node (Param)); - - -- Now we need to generate the Tag check - - else - -- Generate code for tag equality check - -- Perhaps should have Checks.Apply_Tag_Equality_Check??? - - Insert_Action (Ctrl_Arg, - Make_Implicit_If_Statement (Call_Node, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => - Make_Selected_Component (Loc, - Prefix => New_Value (Ctrl_Arg), - Selector_Name => - New_Reference_To - (First_Tag_Component (Typ), Loc)), - - Right_Opnd => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (Typ, New_Value (Param)), - Selector_Name => - New_Reference_To - (First_Tag_Component (Typ), Loc))), - - Then_Statements => - New_List (New_Constraint_Error (Loc)))); - - Append_To (New_Params, Relocate_Node (Param)); end if; Next_Actual (Param); @@ -554,7 +710,7 @@ package body Exp_Disp is Res_Typ := Etype (Subp); end if; - Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node); + Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node); 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)); @@ -612,9 +768,14 @@ package body Exp_Disp is Create_Extra_Formals (Subp_Typ); end; + -- Complete description of pointer type, including size information, as + -- must be done with itypes to prevent order-of-elaboration anomalies + -- in gigi. + Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ); Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ)); + Layout_Type (Subp_Ptr_Typ); -- If the controlling argument is a value of type Ada.Tag or an abstract -- interface class-wide type then use it directly. Otherwise, the tag @@ -652,7 +813,7 @@ 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; @@ -661,28 +822,100 @@ package body Exp_Disp is if Is_Predefined_Dispatching_Operation (Subp) or else Is_Predefined_Dispatching_Alias (Subp) then - New_Call_Name := - Unchecked_Convert_To (Subp_Ptr_Typ, - Build_Get_Predefined_Prim_Op_Address (Loc, - Tag_Node => Controlling_Tag, - Position => DT_Position (Subp))); + Build_Get_Predefined_Prim_Op_Address (Loc, + Tag_Node => Controlling_Tag, + Position => DT_Position (Subp), + New_Node => New_Node); -- Handle dispatching calls to user-defined primitives else - New_Call_Name := - Unchecked_Convert_To (Subp_Ptr_Typ, - Build_Get_Prim_Op_Address (Loc, - Typ => Find_Dispatching_Type (Subp), - Tag_Node => Controlling_Tag, - Position => DT_Position (Subp))); + Build_Get_Prim_Op_Address (Loc, + Typ => Find_Dispatching_Type (Subp), + Tag_Node => Controlling_Tag, + Position => DT_Position (Subp), + New_Node => New_Node); end if; - if Nkind (Call_Node) = N_Function_Call then + 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). + + if Generate_SCIL then + + -- Common case: the controlling tag is the tag of an object + -- (for example, obj.tag) + + if Nkind (Controlling_Tag) = N_Selected_Component then + Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag); + + -- 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 + then + Set_SCIL_Controlling_Tag (SCIL_Node, + Name (Parent (Entity (Controlling_Tag)))); + -- If the controlling tag is an identifier, the SCIL node references + -- the corresponding object or parameter declaration + + elsif Nkind (Controlling_Tag) = N_Identifier + and then Nkind_In (Parent (Entity (Controlling_Tag)), + N_Object_Declaration, + N_Parameter_Specification) + then + Set_SCIL_Controlling_Tag (SCIL_Node, + Parent (Entity (Controlling_Tag))); + + -- If the controlling tag is a dereference, the SCIL node references + -- the corresponding object or parameter declaration + + 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) + 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 + -- of the type. + + elsif Nkind (Controlling_Tag) = N_Attribute_Reference + and then Attribute_Name (Controlling_Tag) = Name_Tag + then + Set_SCIL_Controlling_Tag (SCIL_Node, + Parent + (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??? + + elsif Is_Interface (Etype (Controlling_Tag)) then + Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag); + + else + pragma Assert (False); + null; + end if; + end if; + + 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 @@ -696,26 +929,26 @@ 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); end if; else New_Call := Make_Procedure_Call_Statement (Loc, - Name => New_Call_Name, + Name => New_Call_Name, Parameter_Associations => New_Params); end if; @@ -763,11 +996,23 @@ package body Exp_Disp is Iface_Typ := Root_Type (Iface_Typ); end if; + -- If the target type is a tagged synchronized type, the dispatch table + -- info is in the corresponding record type. + + if Is_Concurrent_Type (Iface_Typ) then + Iface_Typ := Corresponding_Record_Type (Iface_Typ); + end if; + + -- Freeze the entity associated with the target interface to have + -- available the attribute Access_Disp_Table. + + Freeze_Before (N, Iface_Typ); + pragma Assert (not Is_Static or else (not Is_Class_Wide_Type (Iface_Typ) and then Is_Interface (Iface_Typ))); - if VM_Target /= No_VM then + if not Tagged_Type_Expansion then -- For VM, just do a conversion ??? @@ -797,9 +1042,6 @@ package body Exp_Disp is -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2 if Is_Access_Type (Operand_Typ) then - pragma Assert - (Is_Interface (Directly_Designated_Type (Operand_Typ))); - Rewrite (N, Unchecked_Convert_To (Etype (N), Make_Function_Call (Loc, @@ -896,7 +1138,8 @@ package body Exp_Disp is Desig_Typ := Etype (Expression (N)); if Is_Access_Type (Desig_Typ) then - Desig_Typ := Directly_Designated_Type (Desig_Typ); + Desig_Typ := + Available_View (Directly_Designated_Type (Desig_Typ)); end if; if Is_Concurrent_Type (Desig_Typ) then @@ -1039,7 +1282,12 @@ package body Exp_Disp is if Nkind (Name (Call_Node)) = N_Explicit_Dereference then Subp := Etype (Name (Call_Node)); - -- Normal case + -- Call using selected component + + elsif Nkind (Name (Call_Node)) = N_Selected_Component then + Subp := Entity (Selector_Name (Name (Call_Node))); + + -- Call using direct name else Subp := Entity (Name (Call_Node)); @@ -1195,33 +1443,29 @@ 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 - - Target := Prim; - while Present (Alias (Target)) loop - Target := Alias (Target); - end loop; - - -- 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 pragma Assert (Ekind (Target) = E_Function @@ -1229,10 +1473,38 @@ package body Exp_Disp is 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 => @@ -1240,9 +1512,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; @@ -1252,13 +1527,26 @@ package body Exp_Disp is Target_Formal := First_Formal (Target); Formal := First (Formals); while Present (Formal) loop + + -- Handle concurrent types + 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 := Directly_Designated_Type (Etype (Target_Formal)); + else + Ftyp := Etype (Target_Formal); + end if; + + 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)) @@ -1274,9 +1562,7 @@ package body Exp_Disp is 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), @@ -1320,9 +1606,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) @@ -1382,8 +1668,7 @@ package body Exp_Disp is -- 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)))); @@ -1404,6 +1689,8 @@ package body Exp_Disp is Set_Is_Thunk (Thunk_Id); + -- Procedure case + if Ekind (Target) = E_Procedure then Thunk_Code := Make_Subprogram_Body (Loc, @@ -1419,8 +1706,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 => @@ -1494,6 +1782,48 @@ package body Exp_Disp is return False; end Is_Predefined_Dispatching_Operation; + --------------------------------------- + -- Is_Predefined_Internal_Operation -- + --------------------------------------- + + function Is_Predefined_Internal_Operation + (E : Entity_Id) return Boolean + is + TSS_Name : TSS_Name_Type; + + begin + if not Is_Dispatching_Operation (E) then + return False; + end if; + + Get_Name_String (Chars (E)); + + -- 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_uAlignment + or else + (Chars (E) = Name_Op_Eq + and then Etype (First_Entity (E)) = Etype (Last_Entity (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 -- ------------------------------------- @@ -1790,6 +2120,11 @@ package body Exp_Disp is 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)); end if; return @@ -2158,6 +2493,11 @@ package body Exp_Disp is RTE (RE_Conditional_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)); end if; return @@ -2981,6 +3321,11 @@ package body Exp_Disp is Make_Identifier (Loc, Name_uM), -- delay mode 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)); end if; return @@ -3127,13 +3472,19 @@ package body Exp_Disp is -- freezes a tagged type, when one of its primitive operations has a -- type in its profile whose full view has not been analyzed yet. - procedure Export_DT (Typ : Entity_Id; DT : Entity_Id); - -- Export the dispatch table entity DT of tagged type Typ. Required to - -- generate forward references and statically allocate the table. + procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0); + -- Export the dispatch table DT of tagged type Typ. Required to generate + -- forward references and statically allocate the table. For primary + -- dispatch tables Index is 0; for secondary dispatch tables the value + -- of index must match the Suffix_Index value assigned to the table by + -- Make_Tags when generating its unique external name, and it is used to + -- retrieve from the Dispatch_Table_Wrappers list associated with Typ + -- the external name generated by Import_DT. procedure Make_Secondary_DT (Typ : Entity_Id; Iface : Entity_Id; + Suffix_Index : Int; Num_Iface_Prims : Nat; Iface_DT_Ptr : Entity_Id; Predef_Prims_Ptr : Entity_Id; @@ -3148,7 +3499,12 @@ 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. + -- 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 -- @@ -3177,14 +3533,29 @@ package body Exp_Disp is -- Export_DT -- --------------- - procedure Export_DT (Typ : Entity_Id; DT : Entity_Id) is + procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0) + is + Count : Nat; + Elmt : Elmt_Id; + begin Set_Is_Statically_Allocated (DT); Set_Is_True_Constant (DT); Set_Is_Exported (DT); - pragma Assert (Present (Dispatch_Table_Wrapper (Typ))); - Get_External_Name (Dispatch_Table_Wrapper (Typ), True); + Count := 0; + Elmt := First_Elmt (Dispatch_Table_Wrappers (Typ)); + while Count /= Index loop + Next_Elmt (Elmt); + Count := Count + 1; + end loop; + + pragma Assert (Related_Type (Node (Elmt)) = Typ); + + Get_External_Name + (Entity => Node (Elmt), + Has_Suffix => True); + Set_Interface_Name (DT, Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); @@ -3202,6 +3573,7 @@ package body Exp_Disp is procedure Make_Secondary_DT (Typ : Entity_Id; Iface : Entity_Id; + Suffix_Index : Int; Num_Iface_Prims : Nat; Iface_DT_Ptr : Entity_Id; Predef_Prims_Ptr : Entity_Id; @@ -3209,13 +3581,16 @@ package body Exp_Disp is Result : List_Id) is Loc : constant Source_Ptr := Sloc (Typ); - Name_DT : constant Name_Id := New_Internal_Name ('T'); + Exporting_Table : constant Boolean := + Building_Static_DT (Typ) + and then Suffix_Index > 0; Iface_DT : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_DT); + 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, - Name_Predef_Prims); + Chars => Name_Predef_Prims); DT_Constr_List : List_Id; DT_Aggr_List : List_Id; Empty_DT : Boolean := False; @@ -3250,10 +3625,10 @@ package body Exp_Disp is Set_Is_True_Constant (Iface_DT); end if; - -- Generate code to create the storage for the Dispatch_Table object. - -- If the number of primitives of Typ is 0 we reserve a dummy single - -- entry for its DT because at run-time the pointer to this dummy - -- entry will be used as the tag. + -- 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 + -- used as the tag. if Num_Iface_Prims = 0 then Empty_DT := True; @@ -3409,6 +3784,7 @@ package body Exp_Disp is -- prim-op-2'address, -- ... -- prim-op-n'address)); + -- for Iface_DT'Alignment use Address'Alignment; -- Stage 3: Initialize the discriminant and the record components @@ -3462,6 +3838,7 @@ package body Exp_Disp is or else not Is_Limited_Type (Typ) or else not Has_Interfaces (Typ) or else not Build_Thunks + or else not RTE_Record_Component_Available (RE_OSD_Table) then -- No OSD table required @@ -3662,10 +4039,16 @@ package body Exp_Disp is Append_Elmt (New_Node, DT_Aggr); + -- Note: Secondary dispatch tables cannot be declared constant + -- because the component Offset_To_Top is currently initialized + -- by the IP routine. + Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Iface_DT, Aliased_Present => True, + Constant_Present => False, + Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To @@ -3673,54 +4056,68 @@ package body Exp_Disp is Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => DT_Constr_List)), - Expression => Make_Aggregate (Loc, - Expressions => DT_Aggr_List))); + Expression => + Make_Aggregate (Loc, + Expressions => DT_Aggr_List))); Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (Iface_DT, Loc), Chars => Name_Alignment, + Expression => Make_Attribute_Reference (Loc, - Prefix => + Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); + if Exporting_Table then + Export_DT (Typ, Iface_DT, Suffix_Index); + -- Generate code to create the pointer to the dispatch table - -- Iface_DT_Ptr : Tag := Tag!(DT'Address); + -- Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address); - 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)))); + -- Note: This declaration is not added here if the table is exported + -- because in such case Make_Tags has already added this declaration. + + else + 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; Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Predef_Prims_Ptr, Constant_Present => True, - Object_Definition => + + Object_Definition => New_Reference_To (RTE (RE_Address), Loc), - Expression => + + Expression => Make_Attribute_Reference (Loc, - Prefix => + Prefix => Make_Selected_Component (Loc, - Prefix => New_Reference_To (Iface_DT, Loc), - Selector_Name => - New_Occurrence_Of - (RTE_Record_Component (RE_Predef_Prims), Loc)), + Prefix => New_Reference_To (Iface_DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Predef_Prims), Loc)), Attribute_Name => Name_Address))); -- Remember entities containing dispatch tables @@ -3865,27 +4262,29 @@ package body Exp_Disp is then declare Save : constant Boolean := Freezing_Library_Level_Tagged_Type; + Prim : Entity_Id; Prim_Elmt : Elmt_Id; Frnodes : List_Id; begin Freezing_Library_Level_Tagged_Type := True; + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop - Frnodes := Freeze_Entity (Node (Prim_Elmt), Loc); + Prim := Node (Prim_Elmt); + Frnodes := Freeze_Entity (Prim, Loc); declare - Subp : constant Entity_Id := Node (Prim_Elmt); F : Entity_Id; begin - F := First_Formal (Subp); + F := First_Formal (Prim); while Present (F) loop - Check_Premature_Freezing (Subp, Etype (F)); + Check_Premature_Freezing (Prim, Etype (F)); Next_Formal (F); end loop; - Check_Premature_Freezing (Subp, Etype (Subp)); + Check_Premature_Freezing (Prim, Etype (Prim)); end; if Present (Frnodes) then @@ -3894,6 +4293,7 @@ package body Exp_Disp is Next_Elmt (Prim_Elmt); end loop; + Freezing_Library_Level_Tagged_Type := Save; end; end if; @@ -3903,7 +4303,14 @@ package body Exp_Disp is if Has_Interfaces (Typ) then Collect_Interface_Components (Typ, Typ_Comps); - Suffix_Index := 0; + -- Each secondary dispatch table is assigned an unique positive + -- suffix index; such value also corresponds with the location of + -- its entity in the Dispatch_Table_Wrappers list (see Make_Tags). + + -- Note: This value must be kept sync with the Suffix_Index values + -- generated by Make_Tags + + Suffix_Index := 1; AI_Tag_Elmt := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); @@ -3915,17 +4322,19 @@ package body Exp_Disp is Make_Secondary_DT (Typ => Typ, Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))), + Suffix_Index => Suffix_Index, 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 => True, Result => Result); - Next_Elmt (AI_Tag_Elmt); - -- Skip the secondary dispatch table of predefined primitives + -- Skip secondary dispatch table and secondary dispatch table of + -- predefined primitives Next_Elmt (AI_Tag_Elmt); + Next_Elmt (AI_Tag_Elmt); -- Build the secondary table containing pointers to primitives -- (used to give support to Generic Dispatching Constructors). @@ -3933,17 +4342,19 @@ package body Exp_Disp is 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); - Next_Elmt (AI_Tag_Elmt); - -- Skip the secondary dispatch table of predefined primitives + -- Skip secondary dispatch table and secondary dispatch table of + -- predefined primitives Next_Elmt (AI_Tag_Elmt); + Next_Elmt (AI_Tag_Elmt); Suffix_Index := Suffix_Index + 1; Next_Elmt (AI_Tag_Comp); @@ -3984,6 +4395,17 @@ 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), @@ -4010,6 +4432,17 @@ package body Exp_Disp is (RTE_Record_Component (RE_NDT_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_Related_Node (New_Node, Last (Result)); + Set_SCIL_Entity (New_Node, Typ); + Insert_Before (Last (Result), New_Node); + end if; + -- Generate: -- DT : Dispatch_Table_Wrapper (Nb_Prim); -- for DT'Alignment use Address'Alignment; @@ -4039,6 +4472,17 @@ 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), @@ -4065,6 +4509,17 @@ package body Exp_Disp is (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_Related_Node (New_Node, Last (Result)); + Set_SCIL_Entity (New_Node, Typ); + Insert_Before (Last (Result), New_Node); + end if; + Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => @@ -4283,12 +4738,13 @@ package body Exp_Disp is -- specific tagged type, as opposed to one of its ancestors. -- If the type is an unconstrained type extension, we are building the -- dispatch table of its anonymous base type, so the external tag, if - -- any was specified, must be retrieved from the first subtype. + -- any was specified, must be retrieved from the first subtype. Go to + -- the full view in case the clause is in the private part. else declare Def : constant Node_Id := Get_Attribute_Definition_Clause - (First_Subtype (Typ), + (Underlying_Type (First_Subtype (Typ)), Attribute_External_Tag); Old_Val : String_Id; @@ -4644,6 +5100,7 @@ package body Exp_Disp is 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, @@ -4723,9 +5180,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) @@ -4831,6 +5287,17 @@ 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), @@ -5055,21 +5522,19 @@ package body Exp_Disp is while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); + -- Retrieve the ultimate alias of the primitive for proper + -- handling of renamings and eliminated primitives. + + E := Ultimate_Alias (Prim); + if Is_Imported (Prim) or else Present (Interface_Alias (Prim)) or else Is_Predefined_Dispatching_Operation (Prim) + or else Is_Eliminated (E) then null; else - -- Traverse the list of aliased entities to handle - -- renamings of predefined primitives. - - E := Prim; - while Present (Alias (E)) loop - E := Alias (E); - end loop; - if not Is_Predefined_Dispatching_Operation (E) and then not Is_Abstract_Subprogram (E) and then not Present (Interface_Alias (E)) @@ -5139,6 +5604,17 @@ 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), @@ -5153,7 +5629,8 @@ package body Exp_Disp is end if; end if; - -- Initialize the table of ancestor tags + -- Initialize the table of ancestor tags if not building static + -- dispatch table if not Building_Static_DT (Typ) and then not Is_Interface (Typ) @@ -5178,11 +5655,10 @@ package body Exp_Disp is (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))); end if; - -- Inherit the dispatch tables of the parent - - -- There is no need to inherit anything from the parent when building - -- static dispatch tables because the whole dispatch table (including - -- inherited primitives) has been already built. + -- Inherit the dispatch tables of the parent. There is no need to + -- inherit anything from the parent when building static dispatch tables + -- because the whole dispatch table (including inherited primitives) has + -- been already built. if Building_Static_DT (Typ) then null; @@ -5442,13 +5918,16 @@ package body Exp_Disp is Append_List_To (Result, Elab_Code); end if; - -- Populate the two auxiliary tables used for dispatching - -- asynchronous, conditional and timed selects for synchronized - -- types that implement a limited interface. + -- 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_05 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)); @@ -5462,8 +5941,8 @@ package body Exp_Disp is Analyze_List (Result, Suppress => All_Checks); Set_Has_Dispatch_Table (Typ); - -- Mark entities containing dispatch tables. Required by the - -- backend to handle them properly. + -- Mark entities containing dispatch tables. Required by the backend to + -- handle them properly. if not Is_Interface (Typ) then declare @@ -5663,57 +6142,38 @@ package body Exp_Disp is --------------- function Make_Tags (Typ : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Tname : constant Name_Id := Chars (Typ); - Result : constant List_Id := New_List; - AI_Tag_Comp : Elmt_Id; - DT : Node_Id; - DT_Constr_List : List_Id; - DT_Ptr : Node_Id; - Predef_Prims_Ptr : Node_Id; - Iface_DT_Ptr : Node_Id; - Nb_Prim : Nat; - Suffix_Index : Int; - Typ_Name : Name_Id; - Typ_Comps : Elist_Id; - - 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; - - -- 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) + Loc : constant Source_Ptr := Sloc (Typ); + Result : constant List_Id := New_List; + + procedure Import_DT + (Tag_Typ : Entity_Id; + DT : Entity_Id; + Is_Secondary_DT : Boolean); + -- 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); + -- Otherwise generate: + -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim); + -- $pragma import (ada, DT); - if Building_Static_DT (Typ) then - DT := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Tname, 'T')); + --------------- + -- Import_DT -- + --------------- - -- Generate: - -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim); - -- $pragma import (ada, DT); + procedure Import_DT + (Tag_Typ : Entity_Id; + DT : Entity_Id; + Is_Secondary_DT : Boolean) + is + DT_Constr_List : List_Id; + Nb_Prim : Nat; - Set_Is_Imported (DT); + begin + Set_Is_Imported (DT); + Set_Ekind (DT, E_Constant); + Set_Related_Type (DT, Typ); -- The scope must be set now to call Get_External_Name @@ -5730,14 +6190,27 @@ package body Exp_Disp is -- Save this entity to allow Make_DT to generate its exportation - Set_Dispatch_Table_Wrapper (Typ, DT); + Append_Elmt (DT, Dispatch_Table_Wrappers (Typ)); - if Has_DT (Typ) then + -- No dispatch table required + + if not Is_Secondary_DT + and then not Has_DT (Tag_Typ) + then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT, + Aliased_Present => True, + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc))); + else -- Calculate the number of primitives of the dispatch table and -- the size of the Type_Specific_Data record. - Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); + 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. @@ -5761,7 +6234,62 @@ package body Exp_Disp is New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => DT_Constr_List)))); + end if; + end Import_DT; + + -- Local variables + + Tname : constant Name_Id := Chars (Typ); + AI_Tag_Comp : Elmt_Id; + DT : Node_Id := Empty; + DT_Ptr : Node_Id; + Predef_Prims_Ptr : Node_Id; + Iface_DT : Node_Id := Empty; + Iface_DT_Ptr : Node_Id; + New_Node : Node_Id; + Suffix_Index : Int; + Typ_Name : Name_Id; + Typ_Comps : Elist_Id; + + -- 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; + + -- 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) + + if Building_Static_DT (Typ) then + Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List); + + 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, @@ -5778,6 +6306,17 @@ package body Exp_Disp is (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_Related_Node (New_Node, Last (Result)); + Set_SCIL_Entity (New_Node, Typ); + Insert_Before (Last (Result), New_Node); + end if; + Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Predef_Prims_Ptr, @@ -5799,14 +6338,6 @@ package body Exp_Disp is else Append_To (Result, Make_Object_Declaration (Loc, - Defining_Identifier => DT, - Aliased_Present => True, - Constant_Present => True, - Object_Definition => - New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc))); - - Append_To (Result, - Make_Object_Declaration (Loc, Defining_Identifier => DT_Ptr, Constant_Present => True, Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), @@ -5820,6 +6351,17 @@ package body Exp_Disp is New_Occurrence_Of (RTE_Record_Component (RE_NDT_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_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; end if; Set_Is_True_Constant (DT_Ptr); @@ -5834,7 +6376,12 @@ package body Exp_Disp is -- 2) Generate the secondary tag entities if Has_Interfaces (Typ) then - Suffix_Index := 0; + + -- Note: The following value of Suffix_Index must be in sync with + -- the Suffix_Index values of secondary dispatch tables generated + -- by Make_DT. + + Suffix_Index := 1; -- For each interface type we build an unique external name -- associated with its corresponding secondary dispatch table. @@ -5848,9 +6395,19 @@ package body Exp_Disp is 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 thunks to user-defined -- primitives covered by this interface. @@ -5868,6 +6425,25 @@ package body Exp_Disp is (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; + -- Secondary dispatch table referencing thunks to predefined -- primitives. @@ -5920,64 +6496,84 @@ package body Exp_Disp is end loop; end if; - -- 3) At the end of Access_Disp_Table we add the entity of an access - -- type declaration. It is used by Build_Get_Prim_Op_Address to - -- expand dispatching calls through the primary dispatch table. + -- 3) At the end of Access_Disp_Table, if the type has user-defined + -- primitives, we add the entity of an access type declaration that + -- is used by Build_Get_Prim_Op_Address to expand dispatching calls + -- through the primary dispatch table. + + if UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))) = 0 then + Analyze_List (Result); -- Generate: -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr; -- type Typ_DT_Acc is access Typ_DT; - declare - Name_DT_Prims : constant Name_Id := - New_External_Name (Tname, 'G'); - Name_DT_Prims_Acc : constant Name_Id := - New_External_Name (Tname, 'H'); - DT_Prims : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_DT_Prims); - DT_Prims_Acc : constant Entity_Id := - Make_Defining_Identifier (Loc, - Name_DT_Prims_Acc); - begin - Append_To (Result, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => DT_Prims, - Type_Definition => - Make_Constrained_Array_Definition (Loc, - Discrete_Subtype_Definitions => New_List ( - Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), - High_Bound => Make_Integer_Literal (Loc, - DT_Entry_Count - (First_Tag_Component (Typ))))), - Component_Definition => - Make_Component_Definition (Loc, + else + declare + Name_DT_Prims : constant Name_Id := + New_External_Name (Tname, 'G'); + Name_DT_Prims_Acc : constant Name_Id := + New_External_Name (Tname, 'H'); + DT_Prims : constant Entity_Id := + Make_Defining_Identifier (Loc, + Name_DT_Prims); + DT_Prims_Acc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Name_DT_Prims_Acc); + begin + Append_To (Result, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => DT_Prims, + Type_Definition => + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Make_Integer_Literal (Loc, + DT_Entry_Count + (First_Tag_Component (Typ))))), + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Reference_To (RTE (RE_Prim_Ptr), Loc))))); + + Append_To (Result, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => DT_Prims_Acc, + Type_Definition => + Make_Access_To_Object_Definition (Loc, Subtype_Indication => - New_Reference_To (RTE (RE_Prim_Ptr), Loc))))); + New_Occurrence_Of (DT_Prims, Loc)))); - Append_To (Result, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => DT_Prims_Acc, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (DT_Prims, Loc)))); + Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ)); - Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ)); + -- Analyze the resulting list and suppress the generation of the + -- Init_Proc associated with the above array declaration because + -- this type is never used in object declarations. It is only used + -- to simplify the expansion associated with dispatching calls. - -- Analyze the resulting list and suppress the generation of the - -- Init_Proc associated with the above array declaration because - -- we never use such type in object declarations; this type is only - -- used to simplify the expansion associated with dispatching calls. + Analyze_List (Result); + Set_Suppress_Init_Proc (Base_Type (DT_Prims)); - Analyze_List (Result); - Set_Suppress_Init_Proc (Base_Type (DT_Prims)); + -- Mark entity of dispatch table. Required by the back end to + -- handle them properly. - -- Mark entity of dispatch table. Required by the backend to handle - -- the properly. + Set_Is_Dispatch_Table_Entity (DT_Prims); + end; + end if; - Set_Is_Dispatch_Table_Entity (DT_Prims); - end; + -- 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; Set_Ekind (DT_Ptr, E_Constant); Set_Is_Tag (DT_Ptr); @@ -5986,6 +6582,22 @@ package body Exp_Disp is return Result; end Make_Tags; + --------------- + -- New_Value -- + --------------- + + function New_Value (From : Node_Id) return Node_Id is + Res : constant Node_Id := Duplicate_Subexpr (From); + begin + if Is_Access_Type (Etype (From)) then + return + Make_Explicit_Dereference (Sloc (From), + Prefix => Res); + else + return Res; + end if; + end New_Value; + ----------------------------------- -- Original_View_In_Visible_Part -- ----------------------------------- @@ -5996,9 +6608,7 @@ package body Exp_Disp is begin -- The scope must be a package - if Ekind (Scop) /= E_Package - and then Ekind (Scop) /= E_Generic_Package - then + if not Is_Package_Or_Generic_Package (Scop) then return False; end if; @@ -6039,6 +6649,13 @@ package body Exp_Disp is Full_Typ := Corresponding_Concurrent_Type (Typ); end if; + -- When a private tagged type is completed by a concurrent type, + -- retrieve the full view. + + if Is_Private_Type (Full_Typ) then + Full_Typ := Full_View (Full_Typ); + end if; + if Ekind (Prim_Op) = E_Function then -- Protected function @@ -6103,17 +6720,16 @@ package body Exp_Disp is -- Register_Primitive -- ------------------------ - procedure Register_Primitive + function Register_Primitive (Loc : Source_Ptr; - Prim : Entity_Id; - Ins_Nod : Node_Id) + Prim : Entity_Id) return List_Id is DT_Ptr : Entity_Id; Iface_Prim : Entity_Id; Iface_Typ : Entity_Id; Iface_DT_Ptr : Entity_Id; Iface_DT_Elmt : Elmt_Id; - L : List_Id; + L : constant List_Id := New_List; Pos : Uint; Tag : Entity_Id; Tag_Typ : Entity_Id; @@ -6124,7 +6740,7 @@ package body Exp_Disp is pragma Assert (not Restriction_Active (No_Dispatching_Calls)); if not RTE_Available (RE_Tag) then - return; + return L; end if; if not Present (Interface_Alias (Prim)) then @@ -6138,7 +6754,7 @@ package body Exp_Disp is DT_Ptr := Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ)))); - Insert_After (Ins_Nod, + Append_To (L, Build_Set_Predefined_Prim_Op_Address (Loc, Tag_Node => New_Reference_To (DT_Ptr, Loc), Position => Pos, @@ -6148,13 +6764,13 @@ package body Exp_Disp is Prefix => New_Reference_To (Prim, Loc), Attribute_Name => Name_Unrestricted_Access)))); - -- Register copy of the pointer to the 'size primitive in the TSD. + -- Register copy of the pointer to the 'size primitive in the TSD if Chars (Prim) = Name_uSize and then RTE_Record_Component_Available (RE_Size_Func) then DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ))); - Insert_After (Ins_Nod, + Append_To (L, Build_Set_Size_Function (Loc, Tag_Node => New_Reference_To (DT_Ptr, Loc), Size_Func => Prim)); @@ -6164,7 +6780,7 @@ package body Exp_Disp is pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ))); - Insert_After (Ins_Nod, + Append_To (L, Build_Set_Prim_Op_Address (Loc, Typ => Tag_Typ, Tag_Node => New_Reference_To (DT_Ptr, Loc), @@ -6193,12 +6809,6 @@ package body Exp_Disp is if not Is_Ancestor (Iface_Typ, Tag_Typ) and then Present (Thunk_Code) then - -- Comment needed on why checks are suppressed. This is not just - -- efficiency, but fundamental functionality (see 1.295 RH, which - -- still does not answer this question) ??? - - Insert_Action (Ins_Nod, Thunk_Code, Suppress => All_Checks); - -- Generate the code necessary to fill the appropriate entry of -- the secondary dispatch table of Prim's controlling type with -- Thunk_Id's address. @@ -6210,7 +6820,8 @@ package body Exp_Disp is Iface_Prim := Interface_Alias (Prim); Pos := DT_Position (Iface_Prim); Tag := First_Tag_Component (Iface_Typ); - L := New_List; + + Prepend_To (L, Thunk_Code); if Is_Predefined_Dispatching_Operation (Prim) or else Is_Predefined_Dispatching_Alias (Prim) @@ -6242,8 +6853,6 @@ package body Exp_Disp is Prefix => New_Reference_To (Alias (Prim), Loc), Attribute_Name => Name_Unrestricted_Access)))); - Insert_Actions_After (Ins_Nod, L); - else pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); @@ -6275,10 +6884,11 @@ package body Exp_Disp is Prefix => New_Reference_To (Alias (Prim), Loc), Attribute_Name => Name_Unrestricted_Access)))); - Insert_Actions_After (Ins_Nod, L); end if; end if; end if; + + return L; end Register_Primitive; ------------------------- @@ -6401,13 +7011,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; @@ -6417,7 +7026,8 @@ 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)) + or else + Is_Predefined_Dispatching_Alias (Prim)) then Count_Prim := Count_Prim + 1; end if; @@ -6509,7 +7119,7 @@ package body Exp_Disp is procedure Set_Fixed_Prim (Pos : Nat) is begin - pragma Assert (Pos >= 0 and then Pos <= Count_Prim); + pragma Assert (Pos <= Count_Prim); Fixed_Prim (Pos) := True; exception when Constraint_Error => @@ -6784,57 +7394,76 @@ package body Exp_Disp is end if; end Set_All_DT_Position; - ----------------------------- - -- Set_Default_Constructor -- - ----------------------------- + -------------------------- + -- Set_CPP_Constructors -- + -------------------------- - procedure Set_Default_Constructor (Typ : Entity_Id) is + procedure Set_CPP_Constructors (Typ : Entity_Id) is Loc : Source_Ptr; Init : Entity_Id; - Param : Entity_Id; E : Entity_Id; + Found : Boolean := False; + P : Node_Id; + Parms : List_Id; begin - -- Look for the default constructor entity. For now only the - -- default constructor has the flag Is_Constructor. + -- Look for the constructor entities E := Next_Entity (Typ); - while Present (E) - and then (Ekind (E) /= E_Function or else not Is_Constructor (E)) - loop + 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_Interface_Name (Init, Interface_Name (E)); + Set_Convention (Init, Convention_C); + Set_Is_Public (Init); + Set_Has_Completion (Init); + end if; + Next_Entity (E); end loop; - -- Create the init procedure - - if Present (E) then - Loc := Sloc (E); - Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ)); - Param := Make_Defining_Identifier (Loc, Name_X); - - Discard_Node ( - Make_Subprogram_Declaration (Loc, - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Init, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Param, - Parameter_Type => New_Reference_To (Typ, Loc)))))); - - 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); - -- If there are no constructors, mark the type as abstract since we -- won't be able to declare objects of that type. - else + if not Found then Set_Is_Abstract_Type (Typ); end if; - end Set_Default_Constructor; + end Set_CPP_Constructors; -------------------------- -- Set_DTC_Entity_Value -- @@ -7014,6 +7643,10 @@ package body Exp_Disp is Write_Str (" is null;"); end if; + if Is_Eliminated (Ultimate_Alias (Prim)) then + Write_Str (" (eliminated)"); + end if; + Write_Eol; Next_Elmt (Elmt);