diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/exp_disp.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/exp_disp.adb | 4858 |
1 files changed, 4858 insertions, 0 deletions
diff --git a/gcc-4.2.1/gcc/ada/exp_disp.adb b/gcc-4.2.1/gcc/ada/exp_disp.adb new file mode 100644 index 000000000..a29714e97 --- /dev/null +++ b/gcc-4.2.1/gcc/ada/exp_disp.adb @@ -0,0 +1,4858 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ D I S P -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Ch7; use Exp_Ch7; +with Exp_Dbug; use Exp_Dbug; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Itypes; use Itypes; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Disp; use Sem_Disp; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Exp_Disp is + + -------------------------------- + -- Select_Expansion_Utilities -- + -------------------------------- + + -- The following package contains helper routines used in the expansion of + -- dispatching asynchronous, conditional and timed selects. + + package Select_Expansion_Utilities is + procedure Build_B + (Loc : Source_Ptr; + Params : List_Id); + -- Generate: + -- B : out Communication_Block + + procedure Build_C + (Loc : Source_Ptr; + Params : List_Id); + -- Generate: + -- C : out Prim_Op_Kind + + procedure Build_Common_Dispatching_Select_Statements + (Loc : Source_Ptr; + Typ : Entity_Id; + DT_Ptr : Entity_Id; + Stmts : List_Id); + -- Ada 2005 (AI-345): Generate statements that are common between + -- asynchronous, conditional and timed select expansion. + + procedure Build_F + (Loc : Source_Ptr; + Params : List_Id); + -- Generate: + -- F : out Boolean + + procedure Build_P + (Loc : Source_Ptr; + Params : List_Id); + -- Generate: + -- P : Address + + procedure Build_S + (Loc : Source_Ptr; + Params : List_Id); + -- Generate: + -- S : Integer + + procedure Build_T + (Loc : Source_Ptr; + Typ : Entity_Id; + Params : List_Id); + -- Generate: + -- T : in out Typ + end Select_Expansion_Utilities; + + package body Select_Expansion_Utilities is + + ------------- + -- Build_B -- + ------------- + + procedure Build_B + (Loc : Source_Ptr; + Params : List_Id) + is + begin + Append_To (Params, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uB), + Parameter_Type => + New_Reference_To (RTE (RE_Communication_Block), Loc), + Out_Present => True)); + end Build_B; + + ------------- + -- Build_C -- + ------------- + + procedure Build_C + (Loc : Source_Ptr; + Params : List_Id) + is + begin + Append_To (Params, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uC), + Parameter_Type => + New_Reference_To (RTE (RE_Prim_Op_Kind), Loc), + Out_Present => True)); + end Build_C; + + ------------------------------------------------ + -- Build_Common_Dispatching_Select_Statements -- + ------------------------------------------------ + + procedure Build_Common_Dispatching_Select_Statements + (Loc : Source_Ptr; + Typ : Entity_Id; + DT_Ptr : Entity_Id; + Stmts : List_Id) + is + begin + -- Generate: + -- C := get_prim_op_kind (tag! (<type>VP), S); + + -- where C is the out parameter capturing the call kind and S is the + -- dispatch table slot number. + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + Make_Identifier (Loc, Name_uC), + Expression => + Make_DT_Access_Action (Typ, + Action => + Get_Prim_Op_Kind, + Args => + New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))); + + -- Generate: + + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure; + -- then + -- F := True; + -- return; + + -- where F is the out parameter capturing the status of a potential + -- entry call. + + Append_To (Stmts, + Make_If_Statement (Loc, + + Condition => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Identifier (Loc, Name_uC), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Procedure), Loc)), + Right_Opnd => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Identifier (Loc, Name_uC), + Right_Opnd => + New_Reference_To (RTE ( + RE_POK_Protected_Procedure), Loc)), + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Identifier (Loc, Name_uC), + Right_Opnd => + New_Reference_To (RTE ( + RE_POK_Task_Procedure), Loc)))), + + Then_Statements => + New_List ( + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => New_Reference_To (Standard_True, Loc)), + + Make_Return_Statement (Loc)))); + end Build_Common_Dispatching_Select_Statements; + + ------------- + -- Build_F -- + ------------- + + procedure Build_F + (Loc : Source_Ptr; + Params : List_Id) + is + begin + Append_To (Params, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uF), + Parameter_Type => + New_Reference_To (Standard_Boolean, Loc), + Out_Present => True)); + end Build_F; + + ------------- + -- Build_P -- + ------------- + + procedure Build_P + (Loc : Source_Ptr; + Params : List_Id) + is + begin + Append_To (Params, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uP), + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc))); + end Build_P; + + ------------- + -- Build_S -- + ------------- + + procedure Build_S + (Loc : Source_Ptr; + Params : List_Id) + is + begin + Append_To (Params, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uS), + Parameter_Type => + New_Reference_To (Standard_Integer, Loc))); + end Build_S; + + ------------- + -- Build_T -- + ------------- + + procedure Build_T + (Loc : Source_Ptr; + Typ : Entity_Id; + Params : List_Id) + is + begin + Append_To (Params, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uT), + Parameter_Type => + New_Reference_To (Typ, Loc), + In_Present => True, + Out_Present => True)); + end Build_T; + end Select_Expansion_Utilities; + + package SEU renames Select_Expansion_Utilities; + + Ada_Actions : constant array (DT_Access_Action) of RE_Id := + (CW_Membership => RE_CW_Membership, + IW_Membership => RE_IW_Membership, + DT_Entry_Size => RE_DT_Entry_Size, + DT_Prologue_Size => RE_DT_Prologue_Size, + Get_Access_Level => RE_Get_Access_Level, + Get_Entry_Index => RE_Get_Entry_Index, + Get_External_Tag => RE_Get_External_Tag, + Get_Predefined_Prim_Op_Address => RE_Get_Predefined_Prim_Op_Address, + Get_Prim_Op_Address => RE_Get_Prim_Op_Address, + Get_Prim_Op_Kind => RE_Get_Prim_Op_Kind, + Get_RC_Offset => RE_Get_RC_Offset, + Get_Remotely_Callable => RE_Get_Remotely_Callable, + Get_Tagged_Kind => RE_Get_Tagged_Kind, + Inherit_DT => RE_Inherit_DT, + Inherit_TSD => RE_Inherit_TSD, + Register_Interface_Tag => RE_Register_Interface_Tag, + Register_Tag => RE_Register_Tag, + Set_Access_Level => RE_Set_Access_Level, + Set_Entry_Index => RE_Set_Entry_Index, + Set_Expanded_Name => RE_Set_Expanded_Name, + Set_External_Tag => RE_Set_External_Tag, + Set_Interface_Table => RE_Set_Interface_Table, + Set_Offset_Index => RE_Set_Offset_Index, + Set_OSD => RE_Set_OSD, + Set_Predefined_Prim_Op_Address => RE_Set_Predefined_Prim_Op_Address, + Set_Prim_Op_Address => RE_Set_Prim_Op_Address, + Set_Prim_Op_Kind => RE_Set_Prim_Op_Kind, + Set_RC_Offset => RE_Set_RC_Offset, + Set_Remotely_Callable => RE_Set_Remotely_Callable, + Set_Signature => RE_Set_Signature, + Set_SSD => RE_Set_SSD, + Set_TSD => RE_Set_TSD, + Set_Tagged_Kind => RE_Set_Tagged_Kind, + TSD_Entry_Size => RE_TSD_Entry_Size, + TSD_Prologue_Size => RE_TSD_Prologue_Size); + + Action_Is_Proc : constant array (DT_Access_Action) of Boolean := + (CW_Membership => False, + IW_Membership => False, + DT_Entry_Size => False, + DT_Prologue_Size => False, + Get_Access_Level => False, + Get_Entry_Index => False, + Get_External_Tag => False, + Get_Predefined_Prim_Op_Address => False, + Get_Prim_Op_Address => False, + Get_Prim_Op_Kind => False, + Get_RC_Offset => False, + Get_Remotely_Callable => False, + Get_Tagged_Kind => False, + Inherit_DT => True, + Inherit_TSD => True, + Register_Interface_Tag => True, + Register_Tag => True, + Set_Access_Level => True, + Set_Entry_Index => True, + Set_Expanded_Name => True, + Set_External_Tag => True, + Set_Interface_Table => True, + Set_Offset_Index => True, + Set_OSD => True, + Set_Predefined_Prim_Op_Address => True, + Set_Prim_Op_Address => True, + Set_Prim_Op_Kind => True, + Set_RC_Offset => True, + Set_Remotely_Callable => True, + Set_Signature => True, + Set_SSD => True, + Set_TSD => True, + Set_Tagged_Kind => True, + TSD_Entry_Size => False, + TSD_Prologue_Size => False); + + Action_Nb_Arg : constant array (DT_Access_Action) of Int := + (CW_Membership => 2, + IW_Membership => 2, + DT_Entry_Size => 0, + DT_Prologue_Size => 0, + Get_Access_Level => 1, + Get_Entry_Index => 2, + Get_External_Tag => 1, + Get_Predefined_Prim_Op_Address => 2, + Get_Prim_Op_Address => 2, + Get_Prim_Op_Kind => 2, + Get_RC_Offset => 1, + Get_Remotely_Callable => 1, + Get_Tagged_Kind => 1, + Inherit_DT => 3, + Inherit_TSD => 2, + Register_Interface_Tag => 3, + Register_Tag => 1, + Set_Access_Level => 2, + Set_Entry_Index => 3, + Set_Expanded_Name => 2, + Set_External_Tag => 2, + Set_Interface_Table => 2, + Set_Offset_Index => 3, + Set_OSD => 2, + Set_Predefined_Prim_Op_Address => 3, + Set_Prim_Op_Address => 3, + Set_Prim_Op_Kind => 3, + Set_RC_Offset => 2, + Set_Remotely_Callable => 2, + Set_Signature => 2, + Set_SSD => 2, + Set_TSD => 2, + Set_Tagged_Kind => 2, + TSD_Entry_Size => 0, + TSD_Prologue_Size => 0); + + procedure Collect_All_Interfaces (T : Entity_Id); + -- Ada 2005 (AI-251): Collect the whole list of interfaces that are + -- directly or indirectly implemented by T. Used to compute the size + -- of the table of interfaces. + + function Default_Prim_Op_Position (E : Entity_Id) return Uint; + -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table + -- of the default primitive operations. + + 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. + + function Prim_Op_Kind + (Prim : Entity_Id; + Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Determine the primitive operation kind of Prim + -- according to its type Typ. Return a reference to an RE_Prim_Op_Kind + -- enumeration value. + + function Tagged_Kind (T : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference + -- to an RE_Tagged_Kind enumeration value. + + ---------------------------- + -- Collect_All_Interfaces -- + ---------------------------- + + procedure Collect_All_Interfaces (T : Entity_Id) is + + procedure Add_Interface (Iface : Entity_Id); + -- Add the interface it if is not already in the list + + procedure Collect (Typ : Entity_Id); + -- Subsidiary subprogram used to traverse the whole list + -- of directly and indirectly implemented interfaces + + ------------------- + -- Add_Interface -- + ------------------- + + procedure Add_Interface (Iface : Entity_Id) is + Elmt : Elmt_Id; + + begin + Elmt := First_Elmt (Abstract_Interfaces (T)); + while Present (Elmt) and then Node (Elmt) /= Iface loop + Next_Elmt (Elmt); + end loop; + + if No (Elmt) then + Append_Elmt (Iface, Abstract_Interfaces (T)); + end if; + end Add_Interface; + + ------------- + -- Collect -- + ------------- + + procedure Collect (Typ : Entity_Id) is + Ancestor : Entity_Id; + Id : Node_Id; + Iface : Entity_Id; + Nod : Node_Id; + + begin + if Ekind (Typ) = E_Record_Type_With_Private then + Nod := Type_Definition (Parent (Full_View (Typ))); + else + Nod := Type_Definition (Parent (Typ)); + end if; + + pragma Assert (False + or else Nkind (Nod) = N_Derived_Type_Definition + or else Nkind (Nod) = N_Record_Definition); + + -- Include the ancestor if we are generating the whole list + -- of interfaces. This is used to know the size of the table + -- that stores the tag of all the ancestor interfaces. + + Ancestor := Etype (Typ); + + if Ancestor /= Typ then + Collect (Ancestor); + end if; + + if Is_Interface (Ancestor) then + Add_Interface (Ancestor); + end if; + + -- Traverse the graph of ancestor interfaces + + if Is_Non_Empty_List (Interface_List (Nod)) then + Id := First (Interface_List (Nod)); + while Present (Id) loop + Iface := Etype (Id); + + if Is_Interface (Iface) then + Add_Interface (Iface); + Collect (Iface); + end if; + + Next (Id); + end loop; + end if; + end Collect; + + -- Start of processing for Collect_All_Interfaces + + begin + Collect (T); + end Collect_All_Interfaces; + + ------------------------------ + -- Default_Prim_Op_Position -- + ------------------------------ + + function Default_Prim_Op_Position (E : Entity_Id) return Uint is + TSS_Name : TSS_Name_Type; + + begin + Get_Name_String (Chars (E)); + TSS_Name := + TSS_Name_Type + (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); + + if Chars (E) = Name_uSize then + return Uint_1; + + elsif Chars (E) = Name_uAlignment then + return Uint_2; + + elsif TSS_Name = TSS_Stream_Read then + return Uint_3; + + elsif TSS_Name = TSS_Stream_Write then + return Uint_4; + + elsif TSS_Name = TSS_Stream_Input then + return Uint_5; + + elsif TSS_Name = TSS_Stream_Output then + return Uint_6; + + elsif Chars (E) = Name_Op_Eq then + return Uint_7; + + elsif Chars (E) = Name_uAssign then + return Uint_8; + + elsif TSS_Name = TSS_Deep_Adjust then + return Uint_9; + + elsif TSS_Name = TSS_Deep_Finalize then + return Uint_10; + + elsif Ada_Version >= Ada_05 then + if Chars (E) = Name_uDisp_Asynchronous_Select then + return Uint_11; + + elsif Chars (E) = Name_uDisp_Conditional_Select then + return Uint_12; + + elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then + return Uint_13; + + elsif Chars (E) = Name_uDisp_Get_Task_Id then + return Uint_14; + + elsif Chars (E) = Name_uDisp_Timed_Select then + return Uint_15; + end if; + end if; + + raise Program_Error; + end Default_Prim_Op_Position; + + ----------------------------- + -- Expand_Dispatching_Call -- + ----------------------------- + + procedure Expand_Dispatching_Call (Call_Node : Node_Id) is + Loc : constant Source_Ptr := Sloc (Call_Node); + Call_Typ : constant Entity_Id := Etype (Call_Node); + + Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node); + Param_List : constant List_Id := Parameter_Associations (Call_Node); + Subp : Entity_Id := Entity (Name (Call_Node)); + + CW_Typ : Entity_Id; + New_Call : Node_Id; + New_Call_Name : Node_Id; + New_Params : List_Id := No_List; + Param : Node_Id; + Res_Typ : Entity_Id; + Subp_Ptr_Typ : Entity_Id; + Subp_Typ : Entity_Id; + Typ : Entity_Id; + Eq_Prim_Op : Entity_Id := Empty; + Controlling_Tag : Node_Id; + + 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 Controlling_Type (Subp : Entity_Id) return Entity_Id; + -- Returns the tagged type for which Subp is a primitive subprogram + + --------------- + -- 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), Res); + else + return Res; + end if; + end New_Value; + + ---------------------- + -- Controlling_Type -- + ---------------------- + + function Controlling_Type (Subp : Entity_Id) return Entity_Id is + begin + if Ekind (Subp) = E_Function + and then Has_Controlling_Result (Subp) + then + return Base_Type (Etype (Subp)); + + else + declare + Formal : Entity_Id; + + begin + Formal := First_Formal (Subp); + while Present (Formal) loop + if Is_Controlling_Formal (Formal) then + if Is_Access_Type (Etype (Formal)) then + return Base_Type (Designated_Type (Etype (Formal))); + else + return Base_Type (Etype (Formal)); + end if; + end if; + + Next_Formal (Formal); + end loop; + end; + end if; + + -- Controlling type not found (should never happen) + + return Empty; + end Controlling_Type; + + -- Start of processing for Expand_Dispatching_Call + + begin + Check_Restriction (No_Dispatching_Calls, Call_Node); + + -- If this is an inherited operation that was overridden, the body + -- that is being called is its alias. + + if Present (Alias (Subp)) + and then Is_Inherited_Operation (Subp) + and then No (DTC_Entity (Subp)) + then + Subp := Alias (Subp); + end if; + + -- Expand_Dispatching_Call is called directly from the semantics, + -- so we need a check to see whether expansion is active before + -- proceeding. + + if not Expander_Active then + return; + 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 Etype (Ctrl_Arg) = RTE (RE_Tag) + or else (RTE_Available (RE_Interface_Tag) + and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)) + then + CW_Typ := Class_Wide_Type (Controlling_Type (Subp)); + + elsif Is_Access_Type (Etype (Ctrl_Arg)) then + CW_Typ := Designated_Type (Etype (Ctrl_Arg)); + + else + CW_Typ := Etype (Ctrl_Arg); + 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; + + if Is_CPP_Class (Root_Type (Typ)) then + + -- Create a new parameter list with the displaced 'this' + + New_Params := New_List; + Param := First_Actual (Call_Node); + while Present (Param) loop + Append_To (New_Params, Relocate_Node (Param)); + Next_Actual (Param); + end loop; + + elsif Present (Param_List) then + + -- Generate the Tag checks when appropriate + + New_Params := New_List; + Param := First_Actual (Call_Node); + while Present (Param) loop + + -- 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 + 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) + 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); + end loop; + end if; + + -- Generate the appropriate subprogram pointer type + + if Etype (Subp) = Typ then + Res_Typ := CW_Typ; + else + Res_Typ := Etype (Subp); + end if; + + 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); + Init_Size_Align (Subp_Ptr_Typ); + Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); + + -- 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. + + declare + Old_Formal : Entity_Id := First_Formal (Subp); + New_Formal : Entity_Id; + Extra : Entity_Id; + + begin + if Present (Old_Formal) then + New_Formal := New_Copy (Old_Formal); + Set_First_Entity (Subp_Typ, New_Formal); + Param := First_Actual (Call_Node); + + loop + Set_Scope (New_Formal, Subp_Typ); + + -- Change all the controlling argument types to be class-wide + -- to avoid a recursion in dispatching. + + if Is_Controlling_Formal (New_Formal) then + Set_Etype (New_Formal, Etype (Param)); + end if; + + if Is_Itype (Etype (New_Formal)) then + Extra := New_Copy (Etype (New_Formal)); + + if Ekind (Extra) = E_Record_Subtype + or else Ekind (Extra) = E_Class_Wide_Subtype + then + Set_Cloned_Subtype (Extra, Etype (New_Formal)); + end if; + + Set_Etype (New_Formal, Extra); + Set_Scope (Etype (New_Formal), Subp_Typ); + end if; + + Extra := New_Formal; + Next_Formal (Old_Formal); + exit when No (Old_Formal); + + Set_Next_Entity (New_Formal, New_Copy (Old_Formal)); + Next_Entity (New_Formal); + Next_Actual (Param); + end loop; + Set_Last_Entity (Subp_Typ, Extra); + + -- Copy extra formals + + New_Formal := First_Entity (Subp_Typ); + while Present (New_Formal) loop + if Present (Extra_Constrained (New_Formal)) then + Set_Extra_Formal (Extra, + New_Copy (Extra_Constrained (New_Formal))); + Extra := Extra_Formal (Extra); + Set_Extra_Constrained (New_Formal, Extra); + + elsif Present (Extra_Accessibility (New_Formal)) then + Set_Extra_Formal (Extra, + New_Copy (Extra_Accessibility (New_Formal))); + Extra := Extra_Formal (Extra); + Set_Extra_Accessibility (New_Formal, Extra); + end if; + + Next_Formal (New_Formal); + end loop; + end if; + end; + + Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); + Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ); + + -- If the controlling argument is a value of type Ada.Tag or an abstract + -- interface class-wide type then use it directly. Otherwise, the tag + -- must be extracted from the controlling object. + + if Etype (Ctrl_Arg) = RTE (RE_Tag) + or else (RTE_Available (RE_Interface_Tag) + and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)) + then + Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); + + -- Ada 2005 (AI-251): Abstract interface class-wide type + + elsif Is_Interface (Etype (Ctrl_Arg)) + and then Is_Class_Wide_Type (Etype (Ctrl_Arg)) + then + Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); + + else + Controlling_Tag := + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg), + Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc)); + end if; + + -- Generate: + -- Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos)); + + if Is_Predefined_Dispatching_Operation (Subp) then + New_Call_Name := + Unchecked_Convert_To (Subp_Ptr_Typ, + Make_DT_Access_Action (Typ, + Action => Get_Predefined_Prim_Op_Address, + Args => New_List ( + + -- Vptr + + Unchecked_Convert_To (RTE (RE_Tag), + Controlling_Tag), + + -- Position + + Make_Integer_Literal (Loc, DT_Position (Subp))))); + + else + New_Call_Name := + Unchecked_Convert_To (Subp_Ptr_Typ, + Make_DT_Access_Action (Typ, + Action => Get_Prim_Op_Address, + Args => New_List ( + + -- Vptr + + Unchecked_Convert_To (RTE (RE_Tag), + Controlling_Tag), + + -- Position + + Make_Integer_Literal (Loc, DT_Position (Subp))))); + end if; + + if Nkind (Call_Node) = N_Function_Call then + + -- Ada 2005 (AI-251): A dispatching "=" with an abstract interface + -- just requires the comparison of the tags. + + if Ekind (Etype (Ctrl_Arg)) = E_Class_Wide_Type + and then Is_Interface (Etype (Ctrl_Arg)) + and then Subp = Eq_Prim_Op + then + Param := First_Actual (Call_Node); + + New_Call := + Make_Op_Eq (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Value (Param), + Selector_Name => + New_Reference_To (First_Tag_Component (Typ), Loc)), + + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Typ, + New_Value (Next_Actual (Param))), + Selector_Name => + New_Reference_To (First_Tag_Component (Typ), Loc))); + + else + New_Call := + Make_Function_Call (Loc, + Name => New_Call_Name, + Parameter_Associations => New_Params); + + -- If this is a dispatching "=", we must first compare the tags so + -- we generate: x.tag = y.tag and then x = y + + if Subp = Eq_Prim_Op then + Param := First_Actual (Call_Node); + New_Call := + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Value (Param), + Selector_Name => + New_Reference_To (First_Tag_Component (Typ), + Loc)), + + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Typ, + New_Value (Next_Actual (Param))), + Selector_Name => + New_Reference_To (First_Tag_Component (Typ), + Loc))), + Right_Opnd => New_Call); + end if; + end if; + + else + New_Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Call_Name, + Parameter_Associations => New_Params); + end if; + + Rewrite (Call_Node, New_Call); + Analyze_And_Resolve (Call_Node, Call_Typ); + end Expand_Dispatching_Call; + + --------------------------------- + -- Expand_Interface_Conversion -- + --------------------------------- + + procedure Expand_Interface_Conversion + (N : Node_Id; + Is_Static : Boolean := True) + is + Loc : constant Source_Ptr := Sloc (N); + Operand : constant Node_Id := Expression (N); + Operand_Typ : Entity_Id := Etype (Operand); + Iface_Typ : Entity_Id := Etype (N); + Iface_Tag : Entity_Id; + Fent : Entity_Id; + Func : Node_Id; + P : Node_Id; + Null_Op_Nod : Node_Id; + + begin + pragma Assert (Nkind (Operand) /= N_Attribute_Reference); + + -- Ada 2005 (AI-345): Handle task interfaces + + if Ekind (Operand_Typ) = E_Task_Type + or else Ekind (Operand_Typ) = E_Protected_Type + then + Operand_Typ := Corresponding_Record_Type (Operand_Typ); + end if; + + -- Handle access types to interfaces + + if Is_Access_Type (Iface_Typ) then + Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ)); + end if; + + -- Handle class-wide interface types. This conversion can appear + -- explicitly in the source code. Example: I'Class (Obj) + + if Is_Class_Wide_Type (Iface_Typ) then + Iface_Typ := Etype (Iface_Typ); + end if; + + pragma Assert (not Is_Class_Wide_Type (Iface_Typ) + and then Is_Interface (Iface_Typ)); + + if not Is_Static then + + -- Give error if configurable run time and Displace not available + + if not RTE_Available (RE_Displace) then + Error_Msg_CRT ("abstract interface types", N); + return; + end if; + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Displace), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Expression (N)), + Attribute_Name => Name_Address), + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Iface_Typ))), + Loc)))); + + Analyze (N); + + -- Change the type of the data returned by IW_Convert to + -- indicate that this is a dispatching call. + + declare + New_Itype : Entity_Id; + + begin + New_Itype := Create_Itype (E_Anonymous_Access_Type, N); + Set_Etype (New_Itype, New_Itype); + Init_Size_Align (New_Itype); + Set_Directly_Designated_Type (New_Itype, + Class_Wide_Type (Iface_Typ)); + + Rewrite (N, Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (New_Itype, + Relocate_Node (N)))); + Analyze (N); + end; + + return; + end if; + + Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ); + 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) + + if not Is_Access_Type (Etype (N)) then + Rewrite (N, + Unchecked_Convert_To (Etype (N), + Make_Selected_Component (Loc, + Prefix => Relocate_Node (Expression (N)), + Selector_Name => + New_Occurrence_Of (Iface_Tag, Loc)))); + + else + -- Build internal function to handle the case in which the + -- actual is null. If the actual is null returns null because + -- no displacement is required; otherwise performs a type + -- conversion that will be expanded in the code that returns + -- the value of the displaced actual. That is: + + -- function Func (O : Operand_Typ) return Iface_Typ is + -- begin + -- if O = null then + -- return null; + -- else + -- return Iface_Typ!(O); + -- end if; + -- end Func; + + Fent := + Make_Defining_Identifier (Loc, New_Internal_Name ('F')); + + -- Decorate the "null" in the if-statement condition + + Null_Op_Nod := Make_Null (Loc); + Set_Etype (Null_Op_Nod, Etype (Operand)); + Set_Analyzed (Null_Op_Nod); + + Func := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Fent, + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uO), + Parameter_Type => + New_Reference_To (Etype (Operand), Loc))), + Result_Definition => + New_Reference_To (Etype (N), Loc)), + + Declarations => Empty_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => Make_Identifier (Loc, Name_uO), + Right_Opnd => Null_Op_Nod), + Then_Statements => New_List ( + Make_Return_Statement (Loc, + Make_Null (Loc))), + Else_Statements => New_List ( + Make_Return_Statement (Loc, + Unchecked_Convert_To (Etype (N), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uO), + Selector_Name => + New_Occurrence_Of (Iface_Tag, Loc)), + Attribute_Name => Name_Address)))))))); + + -- Insert the new declaration in the nearest enclosing scope + -- that has declarations. + + P := N; + while not Has_Declarations (Parent (P)) loop + P := Parent (P); + end loop; + + if Is_List_Member (P) then + Insert_Before (P, Func); + + elsif Nkind (Parent (P)) = N_Package_Specification then + Append_To (Visible_Declarations (Parent (P)), Func); + + else + Append_To (Declarations (Parent (P)), Func); + end if; + + Analyze (Func); + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (Fent, Loc), + Parameter_Associations => New_List ( + Relocate_Node (Expression (N))))); + end if; + + Analyze (N); + end Expand_Interface_Conversion; + + ------------------------------ + -- Expand_Interface_Actuals -- + ------------------------------ + + procedure Expand_Interface_Actuals (Call_Node : Node_Id) is + Loc : constant Source_Ptr := Sloc (Call_Node); + Actual : Node_Id; + Actual_Dup : Node_Id; + Actual_Typ : Entity_Id; + Anon : Entity_Id; + Conversion : Node_Id; + Formal : Entity_Id; + Formal_Typ : Entity_Id; + Subp : Entity_Id; + Nam : Name_Id; + Formal_DDT : Entity_Id; + Actual_DDT : Entity_Id; + + begin + -- This subprogram is called directly from the semantics, so we need a + -- check to see whether expansion is active before proceeding. + + if not Expander_Active then + return; + end if; + + -- Call using access to subprogram with explicit dereference + + if Nkind (Name (Call_Node)) = N_Explicit_Dereference then + Subp := Etype (Name (Call_Node)); + + -- Normal case + + else + Subp := Entity (Name (Call_Node)); + end if; + + Formal := First_Formal (Subp); + Actual := First_Actual (Call_Node); + while Present (Formal) loop + + -- Ada 2005 (AI-251): Conversion to interface to force "this" + -- displacement. + + Formal_Typ := Etype (Etype (Formal)); + + if Ekind (Formal_Typ) = E_Record_Type_With_Private then + Formal_Typ := Full_View (Formal_Typ); + end if; + + if Is_Access_Type (Formal_Typ) then + Formal_DDT := Directly_Designated_Type (Formal_Typ); + end if; + + Actual_Typ := Etype (Actual); + + if Is_Access_Type (Actual_Typ) then + Actual_DDT := Directly_Designated_Type (Actual_Typ); + end if; + + if Is_Interface (Formal_Typ) then + + -- No need to displace the pointer if the type of the actual + -- is class-wide of the formal-type interface; in this case the + -- displacement of the pointer was already done at the point of + -- the call to the enclosing subprogram. This case corresponds + -- with the call to P (Obj) in the following example: + + -- type I is interface; + -- procedure P (X : I) is abstract; + + -- procedure General_Op (Obj : I'Class) is + -- begin + -- P (Obj); + -- end General_Op; + + if Is_Class_Wide_Type (Actual_Typ) + and then Etype (Actual_Typ) = Formal_Typ + then + null; + + -- No need to displace the pointer if the type of the actual is a + -- derivation of the formal-type interface because in this case + -- the interface primitives are located in the primary dispatch + -- table. + + elsif Is_Ancestor (Formal_Typ, Actual_Typ) then + null; + + else + Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual)); + Rewrite (Actual, Conversion); + Analyze_And_Resolve (Actual, Formal_Typ); + end if; + + -- Anonymous access type + + elsif Is_Access_Type (Formal_Typ) + and then Is_Interface (Etype (Formal_DDT)) + and then Interface_Present_In_Ancestor + (Typ => Actual_DDT, + Iface => Etype (Formal_DDT)) + then + if Nkind (Actual) = N_Attribute_Reference + and then + (Attribute_Name (Actual) = Name_Access + or else Attribute_Name (Actual) = Name_Unchecked_Access) + then + Nam := Attribute_Name (Actual); + + Conversion := Convert_To (Etype (Formal_DDT), Prefix (Actual)); + + Rewrite (Actual, Conversion); + Analyze_And_Resolve (Actual, Etype (Formal_DDT)); + + Rewrite (Actual, + Unchecked_Convert_To (Formal_Typ, + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Actual), + Attribute_Name => Nam))); + + Analyze_And_Resolve (Actual, Formal_Typ); + + -- No need to displace the pointer if the actual is a class-wide + -- type of the formal-type interface because in this case the + -- displacement of the pointer was already done at the point of + -- the call to the enclosing subprogram (this case is similar + -- to the example described above for the non access-type case) + + elsif Is_Class_Wide_Type (Actual_DDT) + and then Etype (Actual_DDT) = Formal_DDT + then + null; + + -- No need to displace the pointer if the type of the actual is a + -- derivation of the interface (because in this case the interface + -- primitives are located in the primary dispatch table) + + elsif Is_Ancestor (Formal_DDT, Actual_DDT) then + null; + + else + Actual_Dup := Relocate_Node (Actual); + + if From_With_Type (Actual_Typ) then + + -- If the type of the actual parameter comes from a limited + -- with-clause and the non-limited view is already available + -- we replace the anonymous access type by a duplicate decla + -- ration whose designated type is the non-limited view + + if Ekind (Actual_DDT) = E_Incomplete_Type + and then Present (Non_Limited_View (Actual_DDT)) + then + Anon := New_Copy (Actual_Typ); + + if Is_Itype (Anon) then + Set_Scope (Anon, Current_Scope); + end if; + + Set_Directly_Designated_Type (Anon, + Non_Limited_View (Actual_DDT)); + Set_Etype (Actual_Dup, Anon); + + elsif Is_Class_Wide_Type (Actual_DDT) + and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type + and then Present (Non_Limited_View (Etype (Actual_DDT))) + then + Anon := New_Copy (Actual_Typ); + + if Is_Itype (Anon) then + Set_Scope (Anon, Current_Scope); + end if; + + Set_Directly_Designated_Type (Anon, + New_Copy (Actual_DDT)); + Set_Class_Wide_Type (Directly_Designated_Type (Anon), + New_Copy (Class_Wide_Type (Actual_DDT))); + Set_Etype (Directly_Designated_Type (Anon), + Non_Limited_View (Etype (Actual_DDT))); + Set_Etype ( + Class_Wide_Type (Directly_Designated_Type (Anon)), + Non_Limited_View (Etype (Actual_DDT))); + Set_Etype (Actual_Dup, Anon); + end if; + end if; + + Conversion := Convert_To (Formal_Typ, Actual_Dup); + Rewrite (Actual, Conversion); + Analyze_And_Resolve (Actual, Formal_Typ); + end if; + end if; + + Next_Actual (Actual); + Next_Formal (Formal); + end loop; + end Expand_Interface_Actuals; + + ---------------------------- + -- Expand_Interface_Thunk -- + ---------------------------- + + function Expand_Interface_Thunk + (N : Node_Id; + Thunk_Alias : Entity_Id; + Thunk_Id : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Actuals : constant List_Id := New_List; + Decl : constant List_Id := New_List; + Formals : constant List_Id := New_List; + Target : Entity_Id; + New_Code : Node_Id; + Formal : Node_Id; + New_Formal : Node_Id; + Decl_1 : Node_Id; + Decl_2 : Node_Id; + E : Entity_Id; + + begin + -- Traverse the list of alias to find the final target + + Target := Thunk_Alias; + while Present (Alias (Target)) loop + Target := Alias (Target); + end loop; + + -- Duplicate the formals + + Formal := First_Formal (Target); + E := First_Formal (N); + while Present (Formal) loop + New_Formal := Copy_Separate_Tree (Parent (Formal)); + + -- Propagate the parameter type to the copy. This is required to + -- properly handle the case in which the subprogram covering the + -- interface has been inherited: + + -- Example: + -- type I is interface; + -- procedure P (X : in I) is abstract; + + -- type T is tagged null record; + -- procedure P (X : T); + + -- type DT is new T and I with ... + + Set_Parameter_Type (New_Formal, New_Reference_To (Etype (E), Loc)); + Append_To (Formals, New_Formal); + + Next_Formal (Formal); + Next_Formal (E); + end loop; + + -- Give message if configurable run-time and Offset_To_Top unavailable + + if not RTE_Available (RE_Offset_To_Top) then + Error_Msg_CRT ("abstract interface types", N); + return Empty; + end if; + + if Ekind (First_Formal (Target)) = E_In_Parameter + and then Ekind (Etype (First_Formal (Target))) + = E_Anonymous_Access_Type + then + -- Generate: + + -- type T is access all <<type of the first formal>> + -- S1 := Storage_Offset!(First_formal) + -- - Offset_To_Top (First_Formal.Tag) + + -- ... and the first actual of the call is generated as T!(S1) + + Decl_2 := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('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 (First_Formal (Target))), Loc))); + + Decl_1 := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('S')), + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Storage_Offset), Loc), + Expression => + Make_Op_Subtract (Loc, + Left_Opnd => + Unchecked_Convert_To + (RTE (RE_Storage_Offset), + New_Reference_To + (Defining_Identifier (First (Formals)), Loc)), + Right_Opnd => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To + (RTE (RE_Address), + New_Reference_To + (Defining_Identifier (First (Formals)), Loc)))))); + + Append_To (Decl, Decl_2); + Append_To (Decl, Decl_1); + + -- Reference the new first actual + + Append_To (Actuals, + Unchecked_Convert_To + (Defining_Identifier (Decl_2), + New_Reference_To (Defining_Identifier (Decl_1), Loc))); + + else + -- Generate: + + -- S1 := Storage_Offset!(First_formal'Address) + -- - Offset_To_Top (First_Formal.Tag) + -- S2 := Tag_Ptr!(S3) + + Decl_1 := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, New_Internal_Name ('S')), + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Storage_Offset), Loc), + Expression => + Make_Op_Subtract (Loc, + Left_Opnd => + Unchecked_Convert_To + (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To + (Defining_Identifier (First (Formals)), Loc), + Attribute_Name => Name_Address)), + Right_Opnd => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To + (Defining_Identifier (First (Formals)), + Loc), + Attribute_Name => Name_Address))))); + + 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 => + Unchecked_Convert_To + (RTE (RE_Addr_Ptr), + New_Reference_To (Defining_Identifier (Decl_1), Loc))); + + Append_To (Decl, Decl_1); + Append_To (Decl, Decl_2); + + -- Reference the new first actual + + Append_To (Actuals, + Unchecked_Convert_To + (Etype (First_Entity (Target)), + Make_Explicit_Dereference (Loc, + New_Reference_To (Defining_Identifier (Decl_2), Loc)))); + end if; + + Formal := Next (First (Formals)); + while Present (Formal) loop + Append_To (Actuals, + New_Reference_To (Defining_Identifier (Formal), Loc)); + Next (Formal); + end loop; + + if Ekind (Target) = E_Procedure then + New_Code := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Thunk_Id, + Parameter_Specifications => Formals), + Declarations => Decl, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Target, Loc), + Parameter_Associations => Actuals)))); + + else pragma Assert (Ekind (Target) = E_Function); + + New_Code := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Thunk_Id, + Parameter_Specifications => Formals, + Result_Definition => + New_Copy (Result_Definition (Parent (Target)))), + Declarations => Decl, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Return_Statement (Loc, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Target, Loc), + Parameter_Associations => Actuals))))); + end if; + + Analyze (New_Code); + return New_Code; + end Expand_Interface_Thunk; + + ------------------- + -- Fill_DT_Entry -- + ------------------- + + function Fill_DT_Entry + (Loc : Source_Ptr; + Prim : Entity_Id) return Node_Id + is + Typ : constant Entity_Id := Scope (DTC_Entity (Prim)); + DT_Ptr : constant Entity_Id := + Node (First_Elmt (Access_Disp_Table (Typ))); + Pos : constant Uint := DT_Position (Prim); + Tag : constant Entity_Id := First_Tag_Component (Typ); + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + if Is_Predefined_Dispatching_Operation (Prim) then + return + Make_DT_Access_Action (Typ, + Action => Set_Predefined_Prim_Op_Address, + Args => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), -- DTptr + + Make_Integer_Literal (Loc, Pos), -- Position + + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (Prim, Loc), + Attribute_Name => Name_Address))); + else + pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); + + return + Make_DT_Access_Action (Typ, + Action => Set_Prim_Op_Address, + Args => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), -- DTptr + + Make_Integer_Literal (Loc, Pos), -- Position + + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (Prim, Loc), + Attribute_Name => Name_Address))); + end if; + end Fill_DT_Entry; + + ----------------------------- + -- Fill_Secondary_DT_Entry -- + ----------------------------- + + function Fill_Secondary_DT_Entry + (Loc : Source_Ptr; + Prim : Entity_Id; + Thunk_Id : Entity_Id; + Iface_DT_Ptr : Entity_Id) return Node_Id + is + Typ : constant Entity_Id := Scope (DTC_Entity (Alias (Prim))); + Iface_Prim : constant Entity_Id := Abstract_Interface_Alias (Prim); + Pos : constant Uint := DT_Position (Iface_Prim); + Tag : constant Entity_Id := + First_Tag_Component (Scope (DTC_Entity (Iface_Prim))); + + begin + if Is_Predefined_Dispatching_Operation (Prim) then + return + Make_DT_Access_Action (Typ, + Action => Set_Predefined_Prim_Op_Address, + Args => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Iface_DT_Ptr, Loc)), -- DTptr + + Make_Integer_Literal (Loc, Pos), -- Position + + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (Thunk_Id, Loc), + Attribute_Name => Name_Address))); + else + pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); + + return + Make_DT_Access_Action (Typ, + Action => Set_Prim_Op_Address, + Args => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Iface_DT_Ptr, Loc)), -- DTptr + + Make_Integer_Literal (Loc, Pos), -- Position + + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (Thunk_Id, Loc), + Attribute_Name => Name_Address))); + end if; + end Fill_Secondary_DT_Entry; + + --------------------------- + -- Get_Remotely_Callable -- + --------------------------- + + function Get_Remotely_Callable (Obj : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (Obj); + begin + return Make_DT_Access_Action + (Typ => Etype (Obj), + Action => Get_Remotely_Callable, + Args => New_List ( + Make_Selected_Component (Loc, + Prefix => Obj, + Selector_Name => Make_Identifier (Loc, Name_uTag)))); + end Get_Remotely_Callable; + + ------------------------------------------ + -- Init_Predefined_Interface_Primitives -- + ------------------------------------------ + + function Init_Predefined_Interface_Primitives + (Typ : Entity_Id) return List_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + DT_Ptr : constant Node_Id := + Node (First_Elmt (Access_Disp_Table (Typ))); + Result : constant List_Id := New_List; + AI : Elmt_Id; + + begin + -- No need to inherit primitives if we have an abstract interface + -- type or a concurrent type. + + if Is_Interface (Typ) + or else Is_Concurrent_Record_Type (Typ) + or else Restriction_Active (No_Dispatching_Calls) + then + return Result; + end if; + + AI := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); + while Present (AI) loop + + -- All the secondary tables inherit the dispatch table entries + -- associated with predefined primitives. + + -- Generate: + -- Inherit_DT (T'Tag, Iface'Tag, 0); + + Append_To (Result, + Make_DT_Access_Action (Typ, + Action => Inherit_DT, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Node (AI), Loc)), + Node3 => Make_Integer_Literal (Loc, Uint_0)))); + + Next_Elmt (AI); + end loop; + + return Result; + end Init_Predefined_Interface_Primitives; + + ---------------------------------------- + -- Make_Disp_Asynchronous_Select_Body -- + ---------------------------------------- + + function Make_Disp_Asynchronous_Select_Body + (Typ : Entity_Id) return Node_Id + is + Conc_Typ : Entity_Id := Empty; + Decls : constant List_Id := New_List; + DT_Ptr : Entity_Id; + Loc : constant Source_Ptr := Sloc (Typ); + Stmts : constant List_Id := New_List; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + -- Null body is generated for interface types + + if Is_Interface (Typ) then + return + Make_Subprogram_Body (Loc, + 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)))); + end if; + + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); + + if Is_Concurrent_Record_Type (Typ) then + Conc_Typ := Corresponding_Concurrent_Type (Typ); + + -- Generate: + -- I : Integer := Get_Entry_Index (tag! (<type>VP), S); + + -- where I will be used to capture the entry index of the primitive + -- wrapper at position S. + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uI), + Object_Definition => + New_Reference_To (Standard_Integer, Loc), + Expression => + Make_DT_Access_Action (Typ, + Action => + Get_Entry_Index, + Args => + New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))); + + if Ekind (Conc_Typ) = E_Protected_Type then + + -- Generate: + -- Protected_Entry_Call ( + -- T._object'access, + -- protected_entry_index! (I), + -- P, + -- Asynchronous_Call, + -- B); + + -- where T is the protected object, I is the entry index, P are + -- the wrapped parameters and B is the name of the communication + -- block. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), + Parameter_Associations => + New_List ( + + Make_Attribute_Reference (Loc, -- T._object'access + Attribute_Name => + Name_Unchecked_Access, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uT), + Selector_Name => + Make_Identifier (Loc, Name_uObject))), + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To (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), + Make_Identifier (Loc, Name_uB)))); -- comm block + else + pragma Assert (Ekind (Conc_Typ) = E_Task_Type); + + -- Generate: + -- Protected_Entry_Call ( + -- T._task_id, + -- task_entry_index! (I), + -- P, + -- Conditional_Call, + -- F); + + -- where T is the task object, I is the entry index, P are the + -- wrapped parameters and F is the status flag. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Task_Entry_Call), Loc), + 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)), + + 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_uP), -- parameter block + New_Reference_To ( -- Asynchronous_Call + RTE (RE_Asynchronous_Call), Loc), + Make_Identifier (Loc, Name_uF)))); -- status flag + end if; + end if; + + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Asynchronous_Select_Spec (Typ), + Declarations => + Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts)); + end Make_Disp_Asynchronous_Select_Body; + + ---------------------------------------- + -- Make_Disp_Asynchronous_Select_Spec -- + ---------------------------------------- + + function Make_Disp_Asynchronous_Select_Spec + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Def_Id : constant Node_Id := + Make_Defining_Identifier (Loc, + Name_uDisp_Asynchronous_Select); + Params : constant List_Id := New_List; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + -- "T" - Object parameter + -- "S" - Primitive operation slot + -- "P" - Wrapped parameters + -- "B" - Communication block + -- "F" - Status flag + + SEU.Build_T (Loc, Typ, Params); + SEU.Build_S (Loc, Params); + SEU.Build_P (Loc, Params); + SEU.Build_B (Loc, Params); + SEU.Build_F (Loc, Params); + + Set_Is_Internal (Def_Id); + + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Def_Id, + Parameter_Specifications => Params); + end Make_Disp_Asynchronous_Select_Spec; + + --------------------------------------- + -- Make_Disp_Conditional_Select_Body -- + --------------------------------------- + + function Make_Disp_Conditional_Select_Body + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Blk_Nam : Entity_Id; + Conc_Typ : Entity_Id := Empty; + Decls : constant List_Id := New_List; + DT_Ptr : Entity_Id; + Stmts : constant List_Id := New_List; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + -- Null body is generated for interface types + + if Is_Interface (Typ) then + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Conditional_Select_Spec (Typ), + Declarations => + No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Make_Null_Statement (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); + + -- Generate: + -- I : Integer; + + -- where I will be used to capture the entry index of the primitive + -- wrapper at position S. + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uI), + Object_Definition => + New_Reference_To (Standard_Integer, Loc))); + + -- Generate: + -- C := Get_Prim_Op_Kind (tag! (<type>VP), S); + + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure; + -- then + -- F := True; + -- return; + -- end if; + + SEU.Build_Common_Dispatching_Select_Statements + (Loc, Typ, DT_Ptr, Stmts); + + -- Generate: + -- Bnn : Communication_Block; + + -- 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')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Blk_Nam, + Object_Definition => + New_Reference_To (RTE (RE_Communication_Block), Loc))); + + -- Generate: + -- I := Get_Entry_Index (tag! (<type>VP), S); + + -- I is the entry index and S is the dispatch table slot + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + Make_Identifier (Loc, Name_uI), + Expression => + Make_DT_Access_Action (Typ, + Action => + Get_Entry_Index, + Args => + New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))); + + if Ekind (Conc_Typ) = E_Protected_Type then + + -- Generate: + -- Protected_Entry_Call ( + -- T._object'access, + -- protected_entry_index! (I), + -- P, + -- Conditional_Call, + -- Bnn); + + -- where T is the protected object, I is the entry index, P are + -- the wrapped parameters and Bnn is the name of the communication + -- block. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), + Parameter_Associations => + New_List ( + + Make_Attribute_Reference (Loc, -- T._object'access + Attribute_Name => + Name_Unchecked_Access, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uT), + Selector_Name => + Make_Identifier (Loc, Name_uObject))), + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To (RTE (RE_Protected_Entry_Index), Loc), + 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 ( -- Bnn + Blk_Nam, Loc)))); + + -- Generate: + -- F := not Cancelled (Bnn); + + -- where F is the success flag. The status of Cancelled is negated + -- in order to match the behaviour of the version for task types. + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + Make_Identifier (Loc, Name_uF), + Expression => + Make_Op_Not (Loc, + Right_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Cancelled), Loc), + Parameter_Associations => + New_List ( + New_Reference_To (Blk_Nam, Loc)))))); + else + pragma Assert (Ekind (Conc_Typ) = E_Task_Type); + + -- Generate: + -- Protected_Entry_Call ( + -- T._task_id, + -- task_entry_index! (I), + -- P, + -- Conditional_Call, + -- F); + + -- where T is the task object, I is the entry index, P are the + -- wrapped parameters and F is the status flag. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Task_Entry_Call), Loc), + 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)), + + 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_uP), -- parameter block + New_Reference_To ( -- Conditional_Call + RTE (RE_Conditional_Call), Loc), + Make_Identifier (Loc, Name_uF)))); -- status flag + end if; + end if; + + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Conditional_Select_Spec (Typ), + Declarations => + Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts)); + end Make_Disp_Conditional_Select_Body; + + --------------------------------------- + -- Make_Disp_Conditional_Select_Spec -- + --------------------------------------- + + function Make_Disp_Conditional_Select_Spec + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Def_Id : constant Node_Id := + Make_Defining_Identifier (Loc, + Name_uDisp_Conditional_Select); + Params : constant List_Id := New_List; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + -- "T" - Object parameter + -- "S" - Primitive operation slot + -- "P" - Wrapped parameters + -- "C" - Call kind + -- "F" - Status flag + + SEU.Build_T (Loc, Typ, Params); + SEU.Build_S (Loc, Params); + SEU.Build_P (Loc, Params); + SEU.Build_C (Loc, Params); + SEU.Build_F (Loc, Params); + + Set_Is_Internal (Def_Id); + + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Def_Id, + Parameter_Specifications => Params); + end Make_Disp_Conditional_Select_Spec; + + ------------------------------------- + -- Make_Disp_Get_Prim_Op_Kind_Body -- + ------------------------------------- + + 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; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + if Is_Interface (Typ) then + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Get_Prim_Op_Kind_Spec (Typ), + Declarations => + New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Make_Null_Statement (Loc)))); + end if; + + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); + + -- Generate: + -- C := get_prim_op_kind (tag! (<type>VP), S); + + -- where C is the out parameter capturing the call kind and S is the + -- dispatch table slot number. + + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Get_Prim_Op_Kind_Spec (Typ), + Declarations => + New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List ( + Make_Assignment_Statement (Loc, + Name => + Make_Identifier (Loc, Name_uC), + Expression => + Make_DT_Access_Action (Typ, + Action => + Get_Prim_Op_Kind, + Args => + New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))))); + end Make_Disp_Get_Prim_Op_Kind_Body; + + ------------------------------------- + -- Make_Disp_Get_Prim_Op_Kind_Spec -- + ------------------------------------- + + function Make_Disp_Get_Prim_Op_Kind_Spec + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Def_Id : constant Node_Id := + Make_Defining_Identifier (Loc, + Name_uDisp_Get_Prim_Op_Kind); + Params : constant List_Id := New_List; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + -- "T" - Object parameter + -- "S" - Primitive operation slot + -- "C" - Call kind + + SEU.Build_T (Loc, Typ, Params); + SEU.Build_S (Loc, Params); + SEU.Build_C (Loc, Params); + + Set_Is_Internal (Def_Id); + + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Def_Id, + Parameter_Specifications => Params); + end Make_Disp_Get_Prim_Op_Kind_Spec; + + -------------------------------- + -- Make_Disp_Get_Task_Id_Body -- + -------------------------------- + + function Make_Disp_Get_Task_Id_Body + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Ret : Node_Id; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + if Is_Concurrent_Record_Type (Typ) + and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type + then + Ret := + Make_Return_Statement (Loc, + Expression => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uT), + Selector_Name => + Make_Identifier (Loc, Name_uTask_Id))); + + -- A null body is constructed for non-task types + + else + Ret := + Make_Return_Statement (Loc, + Expression => + New_Reference_To (RTE (RO_ST_Null_Task), Loc)); + end if; + + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Get_Task_Id_Spec (Typ), + Declarations => + New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Ret))); + end Make_Disp_Get_Task_Id_Body; + + -------------------------------- + -- Make_Disp_Get_Task_Id_Spec -- + -------------------------------- + + function Make_Disp_Get_Task_Id_Spec + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Def_Id : constant Node_Id := + Make_Defining_Identifier (Loc, + Name_uDisp_Get_Task_Id); + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + Set_Is_Internal (Def_Id); + + return + Make_Function_Specification (Loc, + Defining_Unit_Name => Def_Id, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uT), + Parameter_Type => + New_Reference_To (Typ, Loc))), + Result_Definition => + New_Reference_To (RTE (RO_ST_Task_Id), Loc)); + end Make_Disp_Get_Task_Id_Spec; + + --------------------------------- + -- Make_Disp_Timed_Select_Body -- + --------------------------------- + + function Make_Disp_Timed_Select_Body + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Conc_Typ : Entity_Id := Empty; + Decls : constant List_Id := New_List; + DT_Ptr : Entity_Id; + Stmts : constant List_Id := New_List; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + -- Null body is generated for interface types + + if Is_Interface (Typ) then + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Timed_Select_Spec (Typ), + Declarations => + New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Make_Null_Statement (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); + + -- Generate: + -- I : Integer; + + -- where I will be used to capture the entry index of the primitive + -- wrapper at position S. + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uI), + Object_Definition => + New_Reference_To (Standard_Integer, Loc))); + + -- Generate: + -- C := Get_Prim_Op_Kind (tag! (<type>VP), S); + + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure; + -- then + -- F := True; + -- return; + -- end if; + + SEU.Build_Common_Dispatching_Select_Statements + (Loc, Typ, DT_Ptr, Stmts); + + -- Generate: + -- I := Get_Entry_Index (tag! (<type>VP), S); + + -- I is the entry index and S is the dispatch table slot + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + Make_Identifier (Loc, Name_uI), + Expression => + Make_DT_Access_Action (Typ, + Action => + Get_Entry_Index, + Args => + New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))); + + if Ekind (Conc_Typ) = E_Protected_Type then + + -- Generate: + -- Timed_Protected_Entry_Call ( + -- T._object'access, + -- protected_entry_index! (I), + -- P, + -- D, + -- M, + -- F); + + -- where T is the protected object, I is the entry index, P are + -- the wrapped parameters, D is the delay amount, M is the delay + -- mode and F is the status flag. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc), + Parameter_Associations => + New_List ( + + Make_Attribute_Reference (Loc, -- T._object'access + Attribute_Name => + Name_Unchecked_Access, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uT), + Selector_Name => + Make_Identifier (Loc, Name_uObject))), + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To (RTE (RE_Protected_Entry_Index), Loc), + Expression => + Make_Identifier (Loc, Name_uI)), + + Make_Identifier (Loc, Name_uP), -- parameter block + Make_Identifier (Loc, Name_uD), -- delay + Make_Identifier (Loc, Name_uM), -- delay mode + Make_Identifier (Loc, Name_uF)))); -- status flag + + else + pragma Assert (Ekind (Conc_Typ) = E_Task_Type); + + -- Generate: + -- Timed_Task_Entry_Call ( + -- T._task_id, + -- task_entry_index! (I), + -- P, + -- D, + -- M, + -- F); + + -- where T is the task object, I is the entry index, P are the + -- wrapped parameters, D is the delay amount, M is the delay + -- mode and F is the status flag. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc), + 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)), + + 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_uP), -- parameter block + Make_Identifier (Loc, Name_uD), -- delay + Make_Identifier (Loc, Name_uM), -- delay mode + Make_Identifier (Loc, Name_uF)))); -- status flag + end if; + end if; + + return + Make_Subprogram_Body (Loc, + 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; + + --------------------------------- + -- Make_Disp_Timed_Select_Spec -- + --------------------------------- + + function Make_Disp_Timed_Select_Spec + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Def_Id : constant Node_Id := + Make_Defining_Identifier (Loc, + Name_uDisp_Timed_Select); + Params : constant List_Id := New_List; + + begin + pragma Assert (not Restriction_Active (No_Dispatching_Calls)); + + -- "T" - Object parameter + -- "S" - Primitive operation slot + -- "P" - Wrapped parameters + -- "D" - Delay + -- "M" - Delay Mode + -- "C" - Call kind + -- "F" - Status flag + + SEU.Build_T (Loc, Typ, Params); + SEU.Build_S (Loc, Params); + SEU.Build_P (Loc, Params); + + Append_To (Params, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uD), + Parameter_Type => + New_Reference_To (Standard_Duration, Loc))); + + Append_To (Params, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uM), + Parameter_Type => + New_Reference_To (Standard_Integer, Loc))); + + SEU.Build_C (Loc, Params); + SEU.Build_F (Loc, Params); + + Set_Is_Internal (Def_Id); + + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Def_Id, + Parameter_Specifications => Params); + end Make_Disp_Timed_Select_Spec; + + ------------- + -- Make_DT -- + ------------- + + function Make_DT (Typ : Entity_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (Typ); + Result : constant List_Id := New_List; + Elab_Code : constant List_Id := New_List; + + Tname : constant Name_Id := Chars (Typ); + Name_DT : constant Name_Id := New_External_Name (Tname, 'T'); + Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P'); + Name_SSD : constant Name_Id := New_External_Name (Tname, 'S'); + Name_TSD : constant Name_Id := New_External_Name (Tname, 'B'); + Name_Exname : constant Name_Id := New_External_Name (Tname, 'E'); + Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F'); + Name_ITable : Name_Id; + + DT : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT); + DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr); + SSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_SSD); + TSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD); + Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname); + No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg); + ITable : Node_Id; + + Generalized_Tag : constant Entity_Id := RTE (RE_Tag); + AI : Elmt_Id; + I_Depth : Int; + Nb_Prim : Int; + Num_Ifaces : Int; + Old_Tag1 : Node_Id; + Old_Tag2 : Node_Id; + Parent_Num_Ifaces : Int; + Size_Expr_Node : Node_Id; + TSD_Num_Entries : Int; + + Ancestor_Copy : Entity_Id; + Empty_DT : Boolean := False; + Typ_Copy : Entity_Id; + + begin + if not RTE_Available (RE_Tag) then + Error_Msg_CRT ("tagged types", Typ); + return New_List; + end if; + + -- Calculate the size of the DT and the TSD + + if Is_Interface (Typ) then + + -- Abstract interfaces need neither the DT nor the ancestors table. + -- We reserve a single entry for its DT because at run-time the + -- pointer to this dummy DT will be used as the tag of this abstract + -- interface type. + + Empty_DT := True; + Nb_Prim := 1; + TSD_Num_Entries := 0; + Num_Ifaces := 0; + + else + -- Count the number of interfaces implemented by the ancestors + + Parent_Num_Ifaces := 0; + Num_Ifaces := 0; + + if Typ /= Etype (Typ) then + Ancestor_Copy := New_Copy (Etype (Typ)); + Set_Parent (Ancestor_Copy, Parent (Etype (Typ))); + Set_Abstract_Interfaces (Ancestor_Copy, New_Elmt_List); + Collect_All_Interfaces (Ancestor_Copy); + + AI := First_Elmt (Abstract_Interfaces (Ancestor_Copy)); + while Present (AI) loop + Parent_Num_Ifaces := Parent_Num_Ifaces + 1; + Next_Elmt (AI); + end loop; + end if; + + -- Count the number of additional interfaces implemented by Typ + + Typ_Copy := New_Copy (Typ); + Set_Parent (Typ_Copy, Parent (Typ)); + Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List); + Collect_All_Interfaces (Typ_Copy); + + AI := First_Elmt (Abstract_Interfaces (Typ_Copy)); + while Present (AI) loop + Num_Ifaces := Num_Ifaces + 1; + Next_Elmt (AI); + end loop; + + -- 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 + Parent_Type : Entity_Id := Typ; + P : Entity_Id; + + begin + I_Depth := 0; + loop + P := Etype (Parent_Type); + + if Is_Private_Type (P) then + P := Full_View (Base_Type (P)); + end if; + + exit when P = Parent_Type; + + I_Depth := I_Depth + 1; + Parent_Type := P; + end loop; + end; + + TSD_Num_Entries := I_Depth + 1; + Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); + + -- If the number of primitives of Typ is 0 (or we are compiling with + -- the No_Dispatching_Calls restriction) we reserve a dummy single + -- entry for its DT because at run-time the pointer to this dummy DT + -- will be used as the tag of this tagged type. + + if Nb_Prim = 0 or else Restriction_Active (No_Dispatching_Calls) then + Empty_DT := True; + Nb_Prim := 1; + end if; + end if; + + -- Dispatch table and related entities are allocated statically + + Set_Ekind (DT, E_Variable); + Set_Is_Statically_Allocated (DT); + + Set_Ekind (DT_Ptr, E_Variable); + Set_Is_Statically_Allocated (DT_Ptr); + + if not Is_Interface (Typ) + and then Num_Ifaces > 0 + then + Name_ITable := New_External_Name (Tname, 'I'); + ITable := Make_Defining_Identifier (Loc, Name_ITable); + + Set_Ekind (ITable, E_Variable); + Set_Is_Statically_Allocated (ITable); + end if; + + Set_Ekind (SSD, E_Variable); + Set_Is_Statically_Allocated (SSD); + + Set_Ekind (TSD, E_Variable); + Set_Is_Statically_Allocated (TSD); + + Set_Ekind (Exname, E_Variable); + Set_Is_Statically_Allocated (Exname); + + Set_Ekind (No_Reg, E_Variable); + Set_Is_Statically_Allocated (No_Reg); + + -- Generate code to create the storage for the Dispatch_Table object: + + -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size); + -- for DT'Alignment use Address'Alignment + + Size_Expr_Node := + Make_Op_Add (Loc, + Left_Opnd => Make_DT_Access_Action (Typ, DT_Prologue_Size, No_List), + Right_Opnd => + Make_Op_Multiply (Loc, + Left_Opnd => + Make_DT_Access_Action (Typ, DT_Entry_Size, No_List), + Right_Opnd => + Make_Integer_Literal (Loc, Nb_Prim))); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To + (RTE (RE_Storage_Array), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Size_Expr_Node)))))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (DT, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + -- Generate code to create the pointer to the dispatch table + + -- DT_Ptr : Tag := Tag!(DT'Address); + + -- According to the C++ ABI, the base of the vtable is located after a + -- prologue containing Offset_To_Top, and Typeinfo_Ptr. Hence, we move + -- down the pointer to the real base of the vtable + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT_Ptr, + Constant_Present => True, + Object_Definition => New_Reference_To (Generalized_Tag, Loc), + Expression => + Unchecked_Convert_To (Generalized_Tag, + Make_Op_Add (Loc, + Left_Opnd => + Unchecked_Convert_To (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (DT, Loc), + Attribute_Name => Name_Address)), + Right_Opnd => + Make_DT_Access_Action (Typ, + DT_Prologue_Size, No_List))))); + + -- Generate code to define the boolean that controls registration, in + -- order to avoid multiple registrations for tagged types defined in + -- multiple-called scopes. + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => No_Reg, + Object_Definition => New_Reference_To (Standard_Boolean, Loc), + Expression => New_Reference_To (Standard_True, Loc))); + + -- Set Access_Disp_Table field to be the dispatch table pointer + + if No (Access_Disp_Table (Typ)) then + Set_Access_Disp_Table (Typ, New_Elmt_List); + end if; + + Prepend_Elmt (DT_Ptr, Access_Disp_Table (Typ)); + + -- 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.adb). + + -- TSD: Storage_Array + -- (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size); + -- for TSD'Alignment use Address'Alignment + + Size_Expr_Node := + Make_Op_Add (Loc, + Left_Opnd => + Make_DT_Access_Action (Typ, TSD_Prologue_Size, No_List), + Right_Opnd => + Make_Op_Multiply (Loc, + Left_Opnd => + Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List), + Right_Opnd => + Make_Integer_Literal (Loc, TSD_Num_Entries))); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => TSD, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Size_Expr_Node)))))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (TSD, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + -- Generate: + -- Set_Signature (DT_Ptr, Value); + + if Is_Interface (Typ) then + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Signature, + Args => New_List ( + New_Reference_To (DT_Ptr, Loc), -- DTptr + New_Reference_To (RTE (RE_Abstract_Interface), Loc)))); + + elsif RTE_Available (RE_Set_Signature) then + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Signature, + Args => New_List ( + New_Reference_To (DT_Ptr, Loc), -- DTptr + New_Reference_To (RTE (RE_Primary_DT), Loc)))); + end if; + + -- Generate code to put the Address of the TSD in the dispatch table + -- Set_TSD (DT_Ptr, TSD); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_TSD, + Args => New_List ( + New_Reference_To (DT_Ptr, Loc), -- DTptr + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (TSD, Loc), + Attribute_Name => Name_Address)))); + + -- Set the pointer to the Interfaces_Table (if any). Otherwise the + -- corresponding access component is set to null. + + if Is_Interface (Typ) then + null; + + elsif Num_Ifaces = 0 then + if RTE_Available (RE_Set_Interface_Table) then + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Interface_Table, + Args => New_List ( + New_Reference_To (DT_Ptr, Loc), -- DTptr + New_Reference_To (RTE (RE_Null_Address), Loc)))); -- null + end if; + + -- Generate the Interface_Table object and set the access + -- component if the TSD to it. + + elsif RTE_Available (RE_Set_Interface_Table) then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => ITable, + Aliased_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)))))); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Interface_Table, + Args => New_List ( + New_Reference_To (DT_Ptr, Loc), -- DTptr + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (ITable, Loc), + Attribute_Name => Name_Address)))); + end if; + + -- Generate: + -- Set_Num_Prim_Ops (T'Tag, Nb_Prim) + + if RTE_Available (RE_Set_Num_Prim_Ops) then + if not Is_Interface (Typ) then + if Empty_DT then + Append_To (Elab_Code, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc), + Parameter_Associations => New_List ( + New_Reference_To (DT_Ptr, Loc), + Make_Integer_Literal (Loc, Uint_0)))); + else + Append_To (Elab_Code, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc), + Parameter_Associations => New_List ( + New_Reference_To (DT_Ptr, Loc), + Make_Integer_Literal (Loc, Nb_Prim)))); + end if; + end if; + + if Ada_Version >= Ada_05 + and then not Is_Interface (Typ) + and then not Is_Abstract (Typ) + and then not Is_Controlled (Typ) + and then not Restriction_Active (No_Dispatching_Calls) + then + -- Generate: + -- Set_Type_Kind (T'Tag, Type_Kind (Typ)); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Tagged_Kind, + Args => New_List ( + New_Reference_To (DT_Ptr, Loc), -- DTptr + Tagged_Kind (Typ)))); -- Value + + -- Generate the Select Specific Data table for synchronized + -- types that implement a synchronized interface. The size + -- of the table is constrained by the number of non-predefined + -- primitive operations. + + if not Empty_DT + and then Is_Concurrent_Record_Type (Typ) + and then Implements_Interface ( + Typ => Typ, + Kind => Any_Limited_Interface, + Check_Parent => True) + then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => SSD, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To ( + RTE (RE_Select_Specific_Data), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, Nb_Prim)))))); + + -- Set the pointer to the Select Specific Data table in the TSD + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_SSD, + Args => New_List ( + New_Reference_To (DT_Ptr, Loc), -- DTptr + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (SSD, Loc), + Attribute_Name => Name_Address)))); + end if; + end if; + end if; + + -- Generate: Exname : constant String := full_qualified_name (typ); + -- The type itself may be an anonymous parent type, so use the first + -- subtype to have a user-recognizable name. + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Exname, + Constant_Present => True, + Object_Definition => New_Reference_To (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, + Full_Qualified_Name (First_Subtype (Typ))))); + + -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Expanded_Name, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Exname, Loc), + Attribute_Name => Name_Address)))); + + if not Is_Interface (Typ) then + -- Generate: Set_Access_Level (DT_Ptr, <type's accessibility level>); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Access_Level, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => Make_Integer_Literal (Loc, Type_Access_Level (Typ))))); + end if; + + if Typ = Etype (Typ) + or else Is_CPP_Class (Etype (Typ)) + or else Is_Interface (Typ) + then + Old_Tag1 := + Unchecked_Convert_To (Generalized_Tag, + Make_Integer_Literal (Loc, 0)); + Old_Tag2 := + Unchecked_Convert_To (Generalized_Tag, + Make_Integer_Literal (Loc, 0)); + + else + Old_Tag1 := + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc); + Old_Tag2 := + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc); + end if; + + if Typ /= Etype (Typ) + and then not Is_Interface (Typ) + and then not Restriction_Active (No_Dispatching_Calls) + then + -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent); + + if not Is_Interface (Etype (Typ)) then + if Restriction_Active (No_Dispatching_Calls) then + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Inherit_DT, + Args => New_List ( + Node1 => Old_Tag1, + Node2 => New_Reference_To (DT_Ptr, Loc), + Node3 => Make_Integer_Literal (Loc, Uint_0)))); + else + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Inherit_DT, + Args => New_List ( + Node1 => Old_Tag1, + Node2 => New_Reference_To (DT_Ptr, Loc), + Node3 => Make_Integer_Literal (Loc, + DT_Entry_Count + (First_Tag_Component (Etype (Typ))))))); + end if; + end if; + + -- Inherit the secondary dispatch tables of the ancestor + + if not Restriction_Active (No_Dispatching_Calls) + and then not Is_CPP_Class (Etype (Typ)) + then + declare + Sec_DT_Ancestor : Elmt_Id := + Next_Elmt + (First_Elmt + (Access_Disp_Table (Etype (Typ)))); + Sec_DT_Typ : Elmt_Id := + Next_Elmt + (First_Elmt + (Access_Disp_Table (Typ))); + + procedure Copy_Secondary_DTs (Typ : Entity_Id); + -- Local procedure required to climb through the ancestors and + -- copy the contents of all their secondary dispatch tables. + + ------------------------ + -- Copy_Secondary_DTs -- + ------------------------ + + procedure Copy_Secondary_DTs (Typ : Entity_Id) is + E : Entity_Id; + Iface : Elmt_Id; + + begin + -- Climb to the ancestor (if any) handling private types + + if Present (Full_View (Etype (Typ))) then + if Full_View (Etype (Typ)) /= Typ then + Copy_Secondary_DTs (Full_View (Etype (Typ))); + end if; + + elsif Etype (Typ) /= Typ then + Copy_Secondary_DTs (Etype (Typ)); + end if; + + if Present (Abstract_Interfaces (Typ)) + and then not Is_Empty_Elmt_List + (Abstract_Interfaces (Typ)) + then + Iface := First_Elmt (Abstract_Interfaces (Typ)); + E := First_Entity (Typ); + while Present (E) + and then Present (Node (Sec_DT_Ancestor)) + loop + if Is_Tag (E) and then Chars (E) /= Name_uTag then + if not Is_Interface (Etype (Typ)) then + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Inherit_DT, + Args => New_List ( + Node1 => Unchecked_Convert_To + (RTE (RE_Tag), + New_Reference_To + (Node (Sec_DT_Ancestor), + Loc)), + Node2 => Unchecked_Convert_To + (RTE (RE_Tag), + New_Reference_To + (Node (Sec_DT_Typ), Loc)), + Node3 => Make_Integer_Literal (Loc, + DT_Entry_Count (E))))); + end if; + + Next_Elmt (Sec_DT_Ancestor); + Next_Elmt (Sec_DT_Typ); + Next_Elmt (Iface); + end if; + + Next_Entity (E); + end loop; + end if; + end Copy_Secondary_DTs; + + begin + if Present (Node (Sec_DT_Ancestor)) then + + -- Handle private types + + if Present (Full_View (Typ)) then + Copy_Secondary_DTs (Full_View (Typ)); + else + Copy_Secondary_DTs (Typ); + end if; + end if; + end; + end if; + end if; + + -- Generate: + -- Inherit_TSD (parent'tag, DT_Ptr); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Inherit_TSD, + Args => New_List ( + Node1 => Old_Tag2, + Node2 => New_Reference_To (DT_Ptr, Loc)))); + + if not Is_Interface (Typ) then + + -- For types with no controlled components, generate: + -- Set_RC_Offset (DT_Ptr, 0); + + -- For simple types with controlled components, generate: + -- Set_RC_Offset (DT_Ptr, type._record_controller'position); + + -- For complex types with controlled components where the position + -- of the record controller is not statically computable, if there + -- are controlled components at this level, generate: + -- Set_RC_Offset (DT_Ptr, -1); + -- to indicate that the _controller field is right after the _parent + + -- Or if there are no controlled components at this level, generate: + -- Set_RC_Offset (DT_Ptr, -2); + -- to indicate that we need to get the position from the parent. + + declare + Position : Node_Id; + + begin + if not Has_Controlled_Component (Typ) then + Position := Make_Integer_Literal (Loc, 0); + + elsif Etype (Typ) /= Typ + and then Has_Discriminants (Etype (Typ)) + then + if Has_New_Controlled_Component (Typ) then + Position := Make_Integer_Literal (Loc, -1); + else + Position := Make_Integer_Literal (Loc, -2); + end if; + else + Position := + 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 (Position); + Set_Etype (Prefix (Position), RTE (RE_Record_Controller)); + Set_Etype (Prefix (Prefix (Position)), Typ); + Set_Etype (Selector_Name (Prefix (Position)), + RTE (RE_Record_Controller)); + Set_Etype (Position, RTE (RE_Storage_Offset)); + end if; + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_RC_Offset, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => Position))); + end; + + -- Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is + -- described in E.4 (18) + + declare + Status : Entity_Id; + + begin + Status := + Boolean_Literals + (Is_Pure (Typ) + or else Is_Shared_Passive (Typ) + or else + ((Is_Remote_Types (Typ) + or else Is_Remote_Call_Interface (Typ)) + and then Original_View_In_Visible_Part (Typ)) + or else not Comes_From_Source (Typ)); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Remotely_Callable, + Args => New_List ( + New_Occurrence_Of (DT_Ptr, Loc), + New_Occurrence_Of (Status, Loc)))); + end; + + if RTE_Available (RE_Set_Offset_To_Top) then + -- Generate: + -- Set_Offset_To_Top (0, DT_Ptr, True, 0, null); + + Append_To (Elab_Code, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc), + Parameter_Associations => New_List ( + New_Reference_To (RTE (RE_Null_Address), Loc), + New_Reference_To (DT_Ptr, Loc), + New_Occurrence_Of (Standard_True, Loc), + Make_Integer_Literal (Loc, Uint_0), + New_Reference_To (RTE (RE_Null_Address), Loc)))); + end if; + end if; + + -- Generate: Set_External_Tag (DT_Ptr, exname'Address); + -- Should be the external name not the qualified name??? + + if not Has_External_Tag_Rep_Clause (Typ) then + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_External_Tag, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Exname, Loc), + Attribute_Name => Name_Address)))); + + -- Generate code to register the Tag in the External_Tag hash + -- table for the pure Ada type only. + + -- Register_Tag (Dt_Ptr); + + -- Skip this if routine not available, or in No_Run_Time mode + -- or Typ is an abstract interface type (because the table to + -- register it is not available in the abstract type but in + -- types implementing this interface) + + if not No_Run_Time_Mode + and then RTE_Available (RE_Register_Tag) + and then Is_RTE (Generalized_Tag, RE_Tag) + and then not Is_Interface (Typ) + then + Append_To (Elab_Code, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Register_Tag), Loc), + Parameter_Associations => + New_List (New_Reference_To (DT_Ptr, Loc)))); + end if; + end if; + + -- Generate: + -- if No_Reg then + -- <elab_code> + -- No_Reg := False; + -- end if; + + Append_To (Elab_Code, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (No_Reg, Loc), + Expression => New_Reference_To (Standard_False, Loc))); + + Append_To (Result, + Make_Implicit_If_Statement (Typ, + Condition => New_Reference_To (No_Reg, Loc), + Then_Statements => Elab_Code)); + + -- Ada 2005 (AI-251): Register the tag of the interfaces into + -- the table of implemented interfaces. + + if not Is_Interface (Typ) + and then Num_Ifaces > 0 + then + declare + Position : Int; + + begin + -- If the parent is an interface we must generate code to register + -- all its interfaces; otherwise this code is not needed because + -- Inherit_TSD has already inherited such interfaces. + + if Is_Interface (Etype (Typ)) then + Position := 1; + + AI := First_Elmt (Abstract_Interfaces (Ancestor_Copy)); + while Present (AI) loop + -- Generate: + -- Register_Interface (DT_Ptr, Interface'Tag); + + Append_To (Result, + Make_DT_Access_Action (Typ, + Action => Register_Interface_Tag, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => New_Reference_To + (Node + (First_Elmt + (Access_Disp_Table (Node (AI)))), + Loc), + Node3 => Make_Integer_Literal (Loc, Position)))); + + Position := Position + 1; + Next_Elmt (AI); + end loop; + end if; + + -- Register the interfaces that are not implemented by the + -- ancestor + + if Present (Abstract_Interfaces (Typ_Copy)) then + AI := First_Elmt (Abstract_Interfaces (Typ_Copy)); + + -- Skip the interfaces implemented by the ancestor + + for Count in 1 .. Parent_Num_Ifaces loop + Next_Elmt (AI); + end loop; + + -- Register the additional interfaces + + Position := Parent_Num_Ifaces + 1; + while Present (AI) loop + -- Generate: + -- Register_Interface (DT_Ptr, Interface'Tag); + + Append_To (Result, + Make_DT_Access_Action (Typ, + Action => Register_Interface_Tag, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => New_Reference_To + (Node + (First_Elmt + (Access_Disp_Table (Node (AI)))), + Loc), + Node3 => Make_Integer_Literal (Loc, Position)))); + + Position := Position + 1; + Next_Elmt (AI); + end loop; + end if; + + pragma Assert (Position = Num_Ifaces + 1); + end; + end if; + + return Result; + end Make_DT; + + --------------------------- + -- Make_DT_Access_Action -- + --------------------------- + + function Make_DT_Access_Action + (Typ : Entity_Id; + Action : DT_Access_Action; + Args : List_Id) return Node_Id + is + Action_Name : constant Entity_Id := RTE (Ada_Actions (Action)); + Loc : Source_Ptr; + + begin + if No (Args) then + + -- This is a constant + + return New_Reference_To (Action_Name, Sloc (Typ)); + end if; + + pragma Assert (List_Length (Args) = Action_Nb_Arg (Action)); + + Loc := Sloc (First (Args)); + + if Action_Is_Proc (Action) then + return + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Action_Name, Loc), + Parameter_Associations => Args); + + else + return + Make_Function_Call (Loc, + Name => New_Reference_To (Action_Name, Loc), + Parameter_Associations => Args); + end if; + end Make_DT_Access_Action; + + ----------------------- + -- Make_Secondary_DT -- + ----------------------- + + procedure Make_Secondary_DT + (Typ : Entity_Id; + Ancestor_Typ : Entity_Id; + Suffix_Index : Int; + Iface : Entity_Id; + AI_Tag : Entity_Id; + Acc_Disp_Tables : in out Elist_Id; + Result : out List_Id) + is + Loc : constant Source_Ptr := Sloc (AI_Tag); + Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag); + Name_DT : constant Name_Id := New_Internal_Name ('T'); + Empty_DT : Boolean := False; + Iface_DT : Node_Id; + Iface_DT_Ptr : Node_Id; + Name_DT_Ptr : Name_Id; + Nb_Prim : Int; + OSD : Entity_Id; + Size_Expr_Node : Node_Id; + Tname : Name_Id; + + begin + Result := New_List; + + -- Generate a unique external name associated with the secondary + -- dispatch table. This external name will be used to declare an + -- access to this secondary dispatch table, value that will be used + -- for the elaboration of Typ's objects and also for the elaboration + -- of objects of any derivation of Typ that do not override any + -- primitive operation of Typ. + + Get_Secondary_DT_External_Name (Typ, Ancestor_Typ, Suffix_Index); + + Tname := Name_Find; + Name_DT_Ptr := New_External_Name (Tname, "P"); + Iface_DT := Make_Defining_Identifier (Loc, Name_DT); + Iface_DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr); + + -- Dispatch table and related entities are allocated statically + + Set_Ekind (Iface_DT, E_Variable); + Set_Is_Statically_Allocated (Iface_DT); + + Set_Ekind (Iface_DT_Ptr, E_Variable); + Set_Is_Statically_Allocated (Iface_DT_Ptr); + + -- Generate code to create the storage for the Dispatch_Table object. + -- If the number of primitives of Typ is 0 we reserve a dummy single + -- entry for its DT because at run-time the pointer to this dummy entry + -- will be used as the tag. + + Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag)); + + if Nb_Prim = 0 then + Empty_DT := True; + Nb_Prim := 1; + end if; + + -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size); + -- for DT'Alignment use Address'Alignment + + Size_Expr_Node := + Make_Op_Add (Loc, + Left_Opnd => Make_DT_Access_Action (Etype (AI_Tag), + DT_Prologue_Size, + No_List), + Right_Opnd => + Make_Op_Multiply (Loc, + Left_Opnd => + Make_DT_Access_Action (Etype (AI_Tag), + DT_Entry_Size, + No_List), + Right_Opnd => + Make_Integer_Literal (Loc, Nb_Prim))); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Iface_DT, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Size_Expr_Node)))))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (Iface_DT, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + -- Generate code to create the pointer to the dispatch table + + -- Iface_DT_Ptr : Tag := Tag!(DT'Address); + + -- According to the C++ ABI, the base of the vtable is located + -- after the following prologue: Offset_To_Top, and Typeinfo_Ptr. + -- Hence, move the pointer down to the real base of the vtable. + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Iface_DT_Ptr, + Constant_Present => True, + Object_Definition => New_Reference_To (Generalized_Tag, Loc), + Expression => + Unchecked_Convert_To (Generalized_Tag, + Make_Op_Add (Loc, + Left_Opnd => + Unchecked_Convert_To (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Iface_DT, Loc), + Attribute_Name => Name_Address)), + Right_Opnd => + Make_DT_Access_Action (Etype (AI_Tag), + DT_Prologue_Size, No_List))))); + + -- Note: Offset_To_Top will be initialized by the init subprogram + + -- Set Access_Disp_Table field to be the dispatch table pointer + + if not (Present (Acc_Disp_Tables)) then + Acc_Disp_Tables := New_Elmt_List; + end if; + + Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables); + + -- Step 1: Generate an Object Specific Data (OSD) table + + OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + + -- Nothing to do if configurable run time does not support the + -- Object_Specific_Data entity. + + if not RTE_Available (RE_Object_Specific_Data) then + Error_Msg_CRT ("abstract interface types", Typ); + return; + end if; + + -- Generate: + -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims); + -- where the constraint is used to allocate space for the + -- non-predefined primitive operations only. + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => OSD, + 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)))))); + + Append_To (Result, + Make_DT_Access_Action (Typ, + Action => Set_Signature, + Args => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Iface_DT_Ptr, Loc)), + New_Reference_To (RTE (RE_Secondary_DT), Loc)))); + + -- Generate: + -- Ada.Tags.Set_OSD (Iface_DT_Ptr, OSD); + + Append_To (Result, + Make_DT_Access_Action (Typ, + Action => Set_OSD, + Args => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Iface_DT_Ptr, Loc)), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (OSD, Loc), + Attribute_Name => Name_Address)))); + + -- Generate: + -- Set_Num_Prim_Ops (T'Tag, Nb_Prim) + + if RTE_Available (RE_Set_Num_Prim_Ops) then + if Empty_DT then + Append_To (Result, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Iface_DT_Ptr, Loc)), + Make_Integer_Literal (Loc, Uint_0)))); + else + Append_To (Result, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Iface_DT_Ptr, Loc)), + Make_Integer_Literal (Loc, Nb_Prim)))); + end if; + end if; + + if Ada_Version >= Ada_05 + and then not Is_Interface (Typ) + and then not Is_Abstract (Typ) + and then not Is_Controlled (Typ) + and then RTE_Available (RE_Set_Tagged_Kind) + and then not Restriction_Active (No_Dispatching_Calls) + then + -- Generate: + -- Set_Tagged_Kind (Iface'Tag, Tagged_Kind (Iface)); + + Append_To (Result, + Make_DT_Access_Action (Typ, + Action => Set_Tagged_Kind, + Args => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), -- DTptr + New_Reference_To (Iface_DT_Ptr, Loc)), + Tagged_Kind (Typ)))); -- Value + + if not Empty_DT + and then Is_Concurrent_Record_Type (Typ) + and then Implements_Interface ( + Typ => Typ, + Kind => Any_Limited_Interface, + Check_Parent => True) + then + declare + Prim : Entity_Id; + Prim_Alias : Entity_Id; + Prim_Elmt : Elmt_Id; + + begin + -- Step 2: Populate the OSD table + + Prim_Alias := Empty; + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Present (Abstract_Interface_Alias (Prim)) then + Prim_Alias := Abstract_Interface_Alias (Prim); + end if; + + if Present (Prim_Alias) + and then Present (First_Entity (Prim_Alias)) + and then Etype (First_Entity (Prim_Alias)) = Iface + then + -- Generate: + -- Ada.Tags.Set_Offset_Index (Tag (Iface_DT_Ptr), + -- Secondary_DT_Pos, Primary_DT_pos); + + Append_To (Result, + Make_DT_Access_Action (Iface, + Action => Set_Offset_Index, + Args => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Iface_DT_Ptr, Loc)), + Make_Integer_Literal (Loc, + DT_Position (Prim_Alias)), + Make_Integer_Literal (Loc, + DT_Position (Prim))))); + + Prim_Alias := Empty; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end; + end if; + end if; + end Make_Secondary_DT; + + ------------------------------------- + -- 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; + Prim_Pos : Uint; + Nb_Prim : Int := 0; + + type Examined_Array is array (Int range <>) of Boolean; + + function Find_Entry_Index (E : Entity_Id) return Uint; + -- Given an entry, find its index in the visible declarations of the + -- corresponding concurrent type of Typ. + + ---------------------- + -- Find_Entry_Index -- + ---------------------- + + function Find_Entry_Index (E : Entity_Id) return Uint is + Index : Uint := Uint_1; + Subp_Decl : Entity_Id; + + begin + if Present (Decls) + and then not Is_Empty_List (Decls) + then + Subp_Decl := First (Decls); + while Present (Subp_Decl) loop + if Nkind (Subp_Decl) = N_Entry_Declaration then + if Defining_Identifier (Subp_Decl) = E then + return Index; + end if; + + Index := Index + 1; + end if; + + Next (Subp_Decl); + end loop; + end if; + + return Uint_0; + end Find_Entry_Index; + + -- 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); + + if Ekind (Conc_Typ) = E_Protected_Type then + Decls := Visible_Declarations (Protected_Definition ( + Parent (Conc_Typ))); + else + pragma Assert (Ekind (Conc_Typ) = E_Task_Type); + Decls := Visible_Declarations (Task_Definition ( + Parent (Conc_Typ))); + end if; + end if; + + -- Count the non-predefined primitive operations + + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + if not Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then + Nb_Prim := Nb_Prim + 1; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + declare + Examined : Examined_Array (1 .. Nb_Prim) := (others => False); + + begin + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + Prim_Pos := DT_Position (Prim); + + if not Is_Predefined_Dispatching_Operation (Prim) then + pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim); + + if Examined (UI_To_Int (Prim_Pos)) then + goto Continue; + else + Examined (UI_To_Int (Prim_Pos)) := True; + end if; + + -- The current primitive overrides an interface-level + -- subprogram + + if Present (Abstract_Interface_Alias (Prim)) then + + -- Set the primitive operation kind regardless of subprogram + -- type. Generate: + -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>); + + Append_To (Assignments, + Make_DT_Access_Action (Typ, + Action => + Set_Prim_Op_Kind, + Args => + New_List ( + New_Reference_To (DT_Ptr, Loc), + Make_Integer_Literal (Loc, Prim_Pos), + Prim_Op_Kind (Prim, Typ)))); + + -- Retrieve the root of the alias chain if one is present + + if Present (Alias (Prim)) then + Prim_Als := Prim; + while Present (Alias (Prim_Als)) loop + Prim_Als := Alias (Prim_Als); + end loop; + else + Prim_Als := Empty; + end if; + + -- In the case of an entry wrapper, set the entry index + + if Ekind (Prim) = E_Procedure + and then Present (Prim_Als) + and then Is_Primitive_Wrapper (Prim_Als) + and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry + then + + -- Generate: + -- Ada.Tags.Set_Entry_Index + -- (DT_Ptr, <position>, <index>); + + Append_To (Assignments, + Make_DT_Access_Action (Typ, + Action => + Set_Entry_Index, + Args => + New_List ( + New_Reference_To (DT_Ptr, Loc), + Make_Integer_Literal (Loc, Prim_Pos), + Make_Integer_Literal (Loc, + Find_Entry_Index + (Wrapped_Entity (Prim_Als)))))); + end if; + end if; + end if; + + <<Continue>> + + Next_Elmt (Prim_Elmt); + end loop; + end; + + return Assignments; + end Make_Select_Specific_Data_Table; + + ----------------------------------- + -- Original_View_In_Visible_Part -- + ----------------------------------- + + function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is + Scop : constant Entity_Id := Scope (Typ); + + begin + -- The scope must be a package + + if Ekind (Scop) /= E_Package + and then Ekind (Scop) /= E_Generic_Package + then + return False; + end if; + + -- A type with a private declaration has a private view declared in + -- the visible part. + + if Has_Private_Declaration (Typ) then + return True; + end if; + + return List_Containing (Parent (Typ)) = + Visible_Declarations (Specification (Unit_Declaration_Node (Scop))); + end Original_View_In_Visible_Part; + + ------------------ + -- Prim_Op_Kind -- + ------------------ + + function Prim_Op_Kind + (Prim : Entity_Id; + Typ : Entity_Id) return Node_Id + is + Full_Typ : Entity_Id := Typ; + Loc : constant Source_Ptr := Sloc (Prim); + Prim_Op : Entity_Id; + + begin + -- Retrieve the original primitive operation + + Prim_Op := Prim; + while Present (Alias (Prim_Op)) loop + Prim_Op := Alias (Prim_Op); + end loop; + + if Ekind (Typ) = E_Record_Type + and then Present (Corresponding_Concurrent_Type (Typ)) + then + Full_Typ := Corresponding_Concurrent_Type (Typ); + end if; + + if Ekind (Prim_Op) = E_Function then + + -- Protected function + + if Ekind (Full_Typ) = E_Protected_Type then + return New_Reference_To (RTE (RE_POK_Protected_Function), Loc); + + -- Task function + + elsif Ekind (Full_Typ) = E_Task_Type then + return New_Reference_To (RTE (RE_POK_Task_Function), Loc); + + -- Regular function + + else + return New_Reference_To (RTE (RE_POK_Function), Loc); + end if; + + else + pragma Assert (Ekind (Prim_Op) = E_Procedure); + + if Ekind (Full_Typ) = E_Protected_Type then + + -- Protected entry + + if Is_Primitive_Wrapper (Prim_Op) + and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry + then + return New_Reference_To (RTE (RE_POK_Protected_Entry), Loc); + + -- Protected procedure + + else + return New_Reference_To (RTE (RE_POK_Protected_Procedure), Loc); + end if; + + elsif Ekind (Full_Typ) = E_Task_Type then + + -- Task entry + + if Is_Primitive_Wrapper (Prim_Op) + and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry + then + return New_Reference_To (RTE (RE_POK_Task_Entry), Loc); + + -- Task "procedure". These are the internally Expander-generated + -- procedures (task body for instance). + + else + return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc); + end if; + + -- Regular procedure + + else + return New_Reference_To (RTE (RE_POK_Procedure), Loc); + end if; + end if; + end Prim_Op_Kind; + + ------------------------- + -- Set_All_DT_Position -- + ------------------------- + + procedure Set_All_DT_Position (Typ : Entity_Id) is + Parent_Typ : constant Entity_Id := Etype (Typ); + Root_Typ : constant Entity_Id := Root_Type (Typ); + 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; + + Count_Prim : Int; + DT_Length : Int; + Nb_Prim : Int; + Parent_EC : Int; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + + procedure Validate_Position (Prim : Entity_Id); + -- Check that the position assignated to Prim is completely safe + -- (it has not been assigned to a previously defined primitive + -- operation of Typ) + + ----------------------- + -- Validate_Position -- + ----------------------- + + procedure Validate_Position (Prim : Entity_Id) is + Prim_Elmt : Elmt_Id; + + begin + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) + and then Node (Prim_Elmt) /= Prim + loop + -- Primitive operations covering abstract interfaces are + -- allocated later + + if Present (Abstract_Interface_Alias (Node (Prim_Elmt))) then + null; + + -- Predefined dispatching operations are completely safe. They + -- are allocated at fixed positions in a separate table. + + elsif Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then + null; + + -- Aliased subprograms are safe + + elsif Present (Alias (Prim)) then + null; + + elsif DT_Position (Node (Prim_Elmt)) = DT_Position (Prim) then + + -- Handle aliased subprograms + + declare + Op_1 : Entity_Id; + Op_2 : Entity_Id; + + begin + Op_1 := Node (Prim_Elmt); + loop + if Present (Overridden_Operation (Op_1)) then + Op_1 := Overridden_Operation (Op_1); + elsif Present (Alias (Op_1)) then + Op_1 := Alias (Op_1); + else + exit; + end if; + end loop; + + Op_2 := Prim; + loop + if Present (Overridden_Operation (Op_2)) then + Op_2 := Overridden_Operation (Op_2); + elsif Present (Alias (Op_2)) then + Op_2 := Alias (Op_2); + else + exit; + end if; + end loop; + + if Op_1 /= Op_2 then + raise Program_Error; + end if; + end; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end Validate_Position; + + -- Start of processing for Set_All_DT_Position + + begin + -- Get Entry_Count of the parent + + if Parent_Typ /= Typ + and then DT_Entry_Count (First_Tag_Component (Parent_Typ)) /= No_Uint + then + Parent_EC := UI_To_Int (DT_Entry_Count + (First_Tag_Component (Parent_Typ))); + else + Parent_EC := 0; + end if; + + -- C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable + -- give a coherent set of information + + if Is_CPP_Class (Root_Typ) then + + -- Compute the number of primitive operations in the main Vtable + -- Set their position: + -- - where it was set if overriden or inherited + -- - after the end of the parent vtable otherwise + + Prim_Elmt := First_Prim; + Nb_Prim := 0; + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if not Is_CPP_Class (Typ) then + Set_DTC_Entity (Prim, The_Tag); + + elsif Present (Alias (Prim)) then + Set_DTC_Entity (Prim, DTC_Entity (Alias (Prim))); + Set_DT_Position (Prim, DT_Position (Alias (Prim))); + + elsif No (DTC_Entity (Prim)) and then Is_CPP_Class (Typ) then + Error_Msg_NE ("is a primitive operation of&," & + " pragma Cpp_Virtual required", Prim, Typ); + end if; + + if DTC_Entity (Prim) = The_Tag then + + -- Get the slot from the parent subprogram if any + + declare + H : Entity_Id; + + begin + H := Homonym (Prim); + while Present (H) loop + if Present (DTC_Entity (H)) + and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ + then + Set_DT_Position (Prim, DT_Position (H)); + exit; + end if; + + H := Homonym (H); + end loop; + end; + + -- Otherwise take the canonical slot after the end of the + -- parent Vtable + + if DT_Position (Prim) = No_Uint then + Nb_Prim := Nb_Prim + 1; + Set_DT_Position (Prim, UI_From_Int (Parent_EC + Nb_Prim)); + + elsif UI_To_Int (DT_Position (Prim)) > Parent_EC then + Nb_Prim := Nb_Prim + 1; + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + -- Check that the declared size of the Vtable is bigger or equal + -- than the number of primitive operations (if bigger it means that + -- some of the c++ virtual functions were not imported, that is + -- allowed). + + if DT_Entry_Count (The_Tag) = No_Uint + or else not Is_CPP_Class (Typ) + then + Set_DT_Entry_Count (The_Tag, UI_From_Int (Parent_EC + Nb_Prim)); + + elsif UI_To_Int (DT_Entry_Count (The_Tag)) < Parent_EC + Nb_Prim then + Error_Msg_N ("not enough room in the Vtable for all virtual" + & " functions", The_Tag); + end if; + + -- Check that Positions are not duplicate nor outside the range of + -- the Vtable. + + declare + Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag)); + Pos : Int; + Prim_Pos_Table : array (1 .. Size) of Entity_Id := + (others => Empty); + + begin + Prim_Elmt := First_Prim; + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if DTC_Entity (Prim) = The_Tag then + Pos := UI_To_Int (DT_Position (Prim)); + + if Pos not in Prim_Pos_Table'Range then + Error_Msg_N + ("position not in range of virtual table", Prim); + + elsif Present (Prim_Pos_Table (Pos)) then + Error_Msg_NE ("cannot be at the same position in the" + & " vtable than&", Prim, Prim_Pos_Table (Pos)); + + else + Prim_Pos_Table (Pos) := Prim; + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end; + + -- Generate listing showing the contents of the dispatch tables + + if Debug_Flag_ZZ then + Write_DT (Typ); + end if; + + -- For regular Ada tagged types, just set the DT_Position for + -- each primitive operation. Perform some sanity checks to avoid + -- to build completely inconsistant dispatch tables. + + -- Note that the _Size primitive is always set at position 1 in order + -- to comply with the needs of Ada.Tags.Parent_Size (see documentation + -- in Ada.Tags). + + else + -- 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; + while Present (Prim_Elmt) loop + Count_Prim := Count_Prim + 1; + Prim := Node (Prim_Elmt); + + -- Ada 2005 (AI-251) + + if Present (Abstract_Interface_Alias (Prim)) + and then Is_Interface (Scope (DTC_Entity + (Abstract_Interface_Alias (Prim)))) + then + Set_DTC_Entity (Prim, + Find_Interface_Tag + (T => Typ, + Iface => Scope (DTC_Entity + (Abstract_Interface_Alias (Prim))))); + + else + Set_DTC_Entity (Prim, The_Tag); + end if; + + -- Clear any previous value of the DT_Position attribute. In this + -- way we ensure that the final position of all the primitives is + -- stablished by the following stages of this algorithm. + + Set_DT_Position (Prim, No_Uint); + + Next_Elmt (Prim_Elmt); + end loop; + + declare + Fixed_Prim : array (Int range 0 .. Parent_EC + Count_Prim) + of Boolean := (others => False); + + E : Entity_Id; + + begin + -- Second stage: Register fixed entries + + Nb_Prim := 0; + Prim_Elmt := First_Prim; + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + -- 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)); + + -- Overriding interface primitives of an ancestor + + elsif DT_Position (Prim) = No_Uint + and then Present (Abstract_Interface_Alias (Prim)) + and then Present (DTC_Entity + (Abstract_Interface_Alias (Prim))) + and then DT_Position (Abstract_Interface_Alias (Prim)) + /= No_Uint + and then Is_Inherited_Operation (Prim) + and then Is_Ancestor (Scope + (DTC_Entity + (Abstract_Interface_Alias (Prim))), + Typ) + then + Set_DT_Position (Prim, + DT_Position (Abstract_Interface_Alias (Prim))); + Set_DT_Position (Alias (Prim), + DT_Position (Abstract_Interface_Alias (Prim))); + Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True; + + -- Overriding primitives must use the same entry as the + -- overriden primitive + + elsif DT_Position (Prim) = No_Uint + and then Present (Alias (Prim)) + and then Present (DTC_Entity (Alias (Prim))) + and then DT_Position (Alias (Prim)) /= No_Uint + and then Is_Inherited_Operation (Prim) + and then Is_Ancestor (Scope (DTC_Entity (Alias (Prim))), Typ) + then + E := Alias (Prim); + while not (Present (DTC_Entity (E)) + or else DT_Position (E) = No_Uint) + and then Present (Alias (E)) + loop + E := Alias (E); + end loop; + + pragma Assert (Present (DTC_Entity (E)) + and then + DT_Position (E) /= No_Uint); + + Set_DT_Position (Prim, DT_Position (E)); + Fixed_Prim (UI_To_Int (DT_Position (E))) := True; + + -- If this is not the last element in the chain continue + -- traversing the chain. This is required to properly + -- handling renamed primitives + + while Present (Alias (E)) loop + E := Alias (E); + Fixed_Prim (UI_To_Int (DT_Position (E))) := True; + end loop; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + -- Third stage: Fix the position of all the new primitives + -- Entries associated with primitives covering interfaces + -- are handled in a latter round. + + Prim_Elmt := First_Prim; + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + -- Skip primitives previously set entries + + if Is_Predefined_Dispatching_Operation (Prim) then + null; + + elsif DT_Position (Prim) /= No_Uint then + null; + + elsif Etype (DTC_Entity (Prim)) /= RTE (RE_Tag) then + null; + + -- Primitives covering interface primitives are + -- handled later + + elsif Present (Abstract_Interface_Alias (Prim)) then + null; + + else + -- Take the next available position in the DT + + loop + Nb_Prim := Nb_Prim + 1; + exit when not Fixed_Prim (Nb_Prim); + end loop; + + Set_DT_Position (Prim, UI_From_Int (Nb_Prim)); + Fixed_Prim (Nb_Prim) := True; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end; + + -- Fourth stage: Complete the decoration of primitives covering + -- interfaces (that is, propagate the DT_Position attribute + -- from the aliased primitive) + + Prim_Elmt := First_Prim; + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if DT_Position (Prim) = No_Uint + and then Present (Abstract_Interface_Alias (Prim)) + then + -- Check if this entry will be placed in the primary DT + + if Etype (DTC_Entity (Abstract_Interface_Alias (Prim))) + = RTE (RE_Tag) + then + pragma Assert (DT_Position (Alias (Prim)) /= No_Uint); + Set_DT_Position (Prim, DT_Position (Alias (Prim))); + + -- Otherwise it will be placed in the secondary DT + + else + pragma Assert + (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint); + + Set_DT_Position (Prim, + DT_Position (Abstract_Interface_Alias (Prim))); + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + -- Generate listing showing the contents of the dispatch tables. + -- This action is done before some further static checks because + -- in case of critical errors caused by a wrong dispatch table + -- we need to see the contents of such table. + + if Debug_Flag_ZZ then + Write_DT (Typ); + end if; + + -- Final stage: Ensure that the table is correct plus some further + -- verifications concerning the primitives. + + Prim_Elmt := First_Prim; + DT_Length := 0; + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + -- At this point all the primitives MUST have a position + -- in the dispatch table + + if DT_Position (Prim) = No_Uint then + raise Program_Error; + end if; + + -- Calculate real size of the dispatch table + + if not Is_Predefined_Dispatching_Operation (Prim) + and then UI_To_Int (DT_Position (Prim)) > DT_Length + then + DT_Length := UI_To_Int (DT_Position (Prim)); + end if; + + -- Ensure that the asignated position to non-predefined + -- dispatching operations in the dispatch table is correct. + + if not Is_Predefined_Dispatching_Operation (Prim) then + Validate_Position (Prim); + end if; + + if Chars (Prim) = Name_Finalize then + Finalized := True; + end if; + + if Chars (Prim) = Name_Adjust then + 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. Input is excluded + -- because + + if Is_Abstract (Typ) + and then Is_Abstract (Prim) + and then Present (Alias (Prim)) + and then Is_Derived_Type (Typ) + and then In_Private_Part (Current_Scope) + and then + List_Containing (Parent (Prim)) = + Private_Declarations + (Specification (Unit_Declaration_Node (Current_Scope))) + and then Original_View_In_Visible_Part (Typ) + then + -- We exclude Input and Output stream operations because + -- Limited_Controlled inherits useless Input and Output + -- stream operations from Root_Controlled, which can + -- never be overridden. + + if not Is_TSS (Prim, TSS_Stream_Input) + and then + not Is_TSS (Prim, TSS_Stream_Output) + then + Error_Msg_NE + ("abstract inherited private operation&" & + " must be overridden ('R'M 3.9.3(10))", + Parent (Typ), Prim); + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + -- Additional check + + if Is_Controlled (Typ) then + if not Finalized then + Error_Msg_N + ("controlled type has no explicit Finalize method?", Typ); + + elsif not Adjusted then + Error_Msg_N + ("controlled type has no explicit Adjust method?", Typ); + end if; + end if; + + -- Set the final size of the Dispatch Table + + Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length)); + + -- The derived type must have at least as many components as its + -- parent (for root types, the Etype points back to itself + -- and the test should not fail) + + -- This test fails compiling the partial view of a tagged type + -- derived from an interface which defines the overriding subprogram + -- in the private part. This needs further investigation??? + + if not Has_Private_Declaration (Typ) then + pragma Assert ( + DT_Entry_Count (The_Tag) >= + DT_Entry_Count (First_Tag_Component (Parent_Typ))); + null; + end if; + end if; + end Set_All_DT_Position; + + ----------------------------- + -- Set_Default_Constructor -- + ----------------------------- + + procedure Set_Default_Constructor (Typ : Entity_Id) is + Loc : Source_Ptr; + Init : Entity_Id; + Param : Entity_Id; + E : Entity_Id; + + begin + -- Look for the default constructor entity. For now only the + -- default constructor has the flag Is_Constructor. + + E := Next_Entity (Typ); + while Present (E) + and then (Ekind (E) /= E_Function or else not Is_Constructor (E)) + loop + 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 + Set_Is_Abstract (Typ); + end if; + end Set_Default_Constructor; + + ----------------- + -- Tagged_Kind -- + ----------------- + + function Tagged_Kind (T : Entity_Id) return Node_Id is + Conc_Typ : Entity_Id; + Loc : constant Source_Ptr := Sloc (T); + + begin + pragma Assert + (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind)); + + -- Abstract kinds + + if Is_Abstract (T) then + if Is_Limited_Record (T) then + return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc); + else + return New_Reference_To (RTE (RE_TK_Abstract_Tagged), Loc); + end if; + + -- Concurrent kinds + + elsif Is_Concurrent_Record_Type (T) then + Conc_Typ := Corresponding_Concurrent_Type (T); + + if Ekind (Conc_Typ) = E_Protected_Type then + return New_Reference_To (RTE (RE_TK_Protected), Loc); + else + pragma Assert (Ekind (Conc_Typ) = E_Task_Type); + return New_Reference_To (RTE (RE_TK_Task), Loc); + end if; + + -- Regular tagged kinds + + else + if Is_Limited_Record (T) then + return New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc); + else + return New_Reference_To (RTE (RE_TK_Tagged), Loc); + end if; + end if; + end Tagged_Kind; + + -------------- + -- Write_DT -- + -------------- + + procedure Write_DT (Typ : Entity_Id) is + Elmt : Elmt_Id; + Prim : Node_Id; + + begin + -- Protect this procedure against wrong usage. Required because it will + -- be used directly from GDB + + if not (Typ in First_Node_Id .. Last_Node_Id) + or else not Is_Tagged_Type (Typ) + then + Write_Str ("wrong usage: Write_DT must be used with tagged types"); + Write_Eol; + return; + end if; + + Write_Int (Int (Typ)); + Write_Str (": "); + Write_Name (Chars (Typ)); + + if Is_Interface (Typ) then + Write_Str (" is interface"); + end if; + + Write_Eol; + + Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Elmt) loop + Prim := Node (Elmt); + Write_Str (" - "); + + -- Indicate if this primitive will be allocated in the primary + -- dispatch table or in a secondary dispatch table associated + -- with an abstract interface type + + if Present (DTC_Entity (Prim)) then + if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then + Write_Str ("[P] "); + else + Write_Str ("[s] "); + end if; + end if; + + -- Output the node of this primitive operation and its name + + Write_Int (Int (Prim)); + Write_Str (": "); + + if Is_Predefined_Dispatching_Operation (Prim) then + Write_Str ("(predefined) "); + end if; + + Write_Name (Chars (Prim)); + + -- Indicate if this primitive has an aliased primitive + + if Present (Alias (Prim)) then + Write_Str (" (alias = "); + 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) + + if Present (DTC_Entity (Alias (Prim))) + and then Is_Interface (Scope (DTC_Entity (Alias (Prim)))) + then + Write_Str (" from interface "); + Write_Name (Chars (Scope (DTC_Entity (Alias (Prim))))); + end if; + + if Present (Abstract_Interface_Alias (Prim)) then + Write_Str (", AI_Alias of "); + Write_Name (Chars (Scope (DTC_Entity + (Abstract_Interface_Alias (Prim))))); + Write_Char (':'); + Write_Int (Int (Abstract_Interface_Alias (Prim))); + end if; + + Write_Str (")"); + end if; + + -- Display the final position of this primitive in its associated + -- (primary or secondary) dispatch table + + if Present (DTC_Entity (Prim)) + and then DT_Position (Prim) /= No_Uint + then + Write_Str (" at #"); + Write_Int (UI_To_Int (DT_Position (Prim))); + end if; + + if Is_Abstract (Prim) then + Write_Str (" is abstract;"); + end if; + + Write_Eol; + + Next_Elmt (Elmt); + end loop; + end Write_DT; + +end Exp_Disp; |