diff options
Diffstat (limited to 'gcc/ada/exp_disp.adb')
| -rw-r--r-- | gcc/ada/exp_disp.adb | 1278 |
1 files changed, 1278 insertions, 0 deletions
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb new file mode 100644 index 00000000000..bdddde4a289 --- /dev/null +++ b/gcc/ada/exp_disp.adb @@ -0,0 +1,1278 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ D I S P -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.79 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Ch7; use Exp_Ch7; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Fname; use Fname; +with Itypes; use Itypes; +with Lib; use Lib; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem_Disp; use Sem_Disp; +with Sem_Res; use Sem_Res; +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 + + Ada_Actions : constant array (DT_Access_Action) of RE_Id := + (CW_Membership => RE_CW_Membership, + DT_Entry_Size => RE_DT_Entry_Size, + DT_Prologue_Size => RE_DT_Prologue_Size, + Get_Expanded_Name => RE_Get_Expanded_Name, + Get_External_Tag => RE_Get_External_Tag, + Get_Prim_Op_Address => RE_Get_Prim_Op_Address, + Get_RC_Offset => RE_Get_RC_Offset, + Get_Remotely_Callable => RE_Get_Remotely_Callable, + Get_TSD => RE_Get_TSD, + Inherit_DT => RE_Inherit_DT, + Inherit_TSD => RE_Inherit_TSD, + Register_Tag => RE_Register_Tag, + Set_Expanded_Name => RE_Set_Expanded_Name, + Set_External_Tag => RE_Set_External_Tag, + Set_Prim_Op_Address => RE_Set_Prim_Op_Address, + Set_RC_Offset => RE_Set_RC_Offset, + Set_Remotely_Callable => RE_Set_Remotely_Callable, + Set_TSD => RE_Set_TSD, + TSD_Entry_Size => RE_TSD_Entry_Size, + TSD_Prologue_Size => RE_TSD_Prologue_Size); + + CPP_Actions : constant array (DT_Access_Action) of RE_Id := + (CW_Membership => RE_CPP_CW_Membership, + DT_Entry_Size => RE_CPP_DT_Entry_Size, + DT_Prologue_Size => RE_CPP_DT_Prologue_Size, + Get_Expanded_Name => RE_CPP_Get_Expanded_Name, + Get_External_Tag => RE_CPP_Get_External_Tag, + Get_Prim_Op_Address => RE_CPP_Get_Prim_Op_Address, + Get_RC_Offset => RE_CPP_Get_RC_Offset, + Get_Remotely_Callable => RE_CPP_Get_Remotely_Callable, + Get_TSD => RE_CPP_Get_TSD, + Inherit_DT => RE_CPP_Inherit_DT, + Inherit_TSD => RE_CPP_Inherit_TSD, + Register_Tag => RE_CPP_Register_Tag, + Set_Expanded_Name => RE_CPP_Set_Expanded_Name, + Set_External_Tag => RE_CPP_Set_External_Tag, + Set_Prim_Op_Address => RE_CPP_Set_Prim_Op_Address, + Set_RC_Offset => RE_CPP_Set_RC_Offset, + Set_Remotely_Callable => RE_CPP_Set_Remotely_Callable, + Set_TSD => RE_CPP_Set_TSD, + TSD_Entry_Size => RE_CPP_TSD_Entry_Size, + TSD_Prologue_Size => RE_CPP_TSD_Prologue_Size); + + Action_Is_Proc : constant array (DT_Access_Action) of Boolean := + (CW_Membership => False, + DT_Entry_Size => False, + DT_Prologue_Size => False, + Get_Expanded_Name => False, + Get_External_Tag => False, + Get_Prim_Op_Address => False, + Get_Remotely_Callable => False, + Get_RC_Offset => False, + Get_TSD => False, + Inherit_DT => True, + Inherit_TSD => True, + Register_Tag => True, + Set_Expanded_Name => True, + Set_External_Tag => True, + Set_Prim_Op_Address => True, + Set_RC_Offset => True, + Set_Remotely_Callable => True, + Set_TSD => True, + TSD_Entry_Size => False, + TSD_Prologue_Size => False); + + Action_Nb_Arg : constant array (DT_Access_Action) of Int := + (CW_Membership => 2, + DT_Entry_Size => 0, + DT_Prologue_Size => 0, + Get_Expanded_Name => 1, + Get_External_Tag => 1, + Get_Prim_Op_Address => 2, + Get_RC_Offset => 1, + Get_Remotely_Callable => 1, + Get_TSD => 1, + Inherit_DT => 3, + Inherit_TSD => 2, + Register_Tag => 1, + Set_Expanded_Name => 2, + Set_External_Tag => 2, + Set_Prim_Op_Address => 3, + Set_RC_Offset => 2, + Set_Remotely_Callable => 2, + Set_TSD => 2, + TSD_Entry_Size => 0, + TSD_Prologue_Size => 0); + + 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. + + -------------------------- + -- Expand_Dispatch_Call -- + -------------------------- + + procedure Expand_Dispatch_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; + + function New_Value (From : Node_Id) return Node_Id; + -- From is the original Expression. New_Value is equivalent to + -- Duplicate_Subexpr with an explicit dereference when From is an + -- access parameter + + 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; + + -- Start of processing for Expand_Dispatch_Call + + begin + -- If this is an inherited operation that was overriden, 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_Dispatch 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 ClassWide Type and the Tagged type + + if 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 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 + + -- We assume that dispatching through the main dispatch table + -- (referenced by Tag_Component) doesn't require a displacement + -- so the expansion below is only done when dispatching on + -- another vtable pointer, in which case the first argument + -- is expanded into : + + -- typ!(Displaced_This (Address!(Param))) + + if Param = Ctrl_Arg + and then DTC_Entity (Subp) /= Tag_Component (Typ) + then + Append_To (New_Params, + + Unchecked_Convert_To (Etype (Param), + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Displaced_This), Loc), + Parameter_Associations => New_List ( + + -- Current_This + + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Address), Loc), + Expression => Relocate_Node (Param)), + + -- Vptr + + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Ctrl_Arg), + Selector_Name => + New_Reference_To (DTC_Entity (Subp), Loc)), + + -- Position + + Make_Integer_Literal (Loc, DT_Position (Subp)))))); + + else + Append_To (New_Params, Relocate_Node (Param)); + end if; + + 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 (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 it 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 instead of relocate_node because + -- the value will be duplicated to check the tags. + + elsif Subp = Eq_Prim_Op then + Append_To (New_Params, Duplicate_Subexpr (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 (Tag_Component (Typ), Loc)), + + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Typ, New_Value (Param)), + Selector_Name => + New_Reference_To (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_Actual (Param) 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); + + -- Generate: + -- Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos)); + + New_Call_Name := + Unchecked_Convert_To (Subp_Ptr_Typ, + Make_DT_Access_Action (Typ, + Action => Get_Prim_Op_Address, + Args => New_List ( + + -- Vptr + + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Ctrl_Arg), + Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc)), + + -- Position + + Make_Integer_Literal (Loc, DT_Position (Subp))))); + + if Nkind (Call_Node) = N_Function_Call then + 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 (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 (Tag_Component (Typ), Loc))), + + Right_Opnd => New_Call); + 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_Dispatch_Call; + + ------------- + -- Fill_DT -- + ------------- + + 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 := Access_Disp_Table (Typ); + + begin + return + Make_DT_Access_Action (Typ, + Action => Set_Prim_Op_Address, + Args => New_List ( + New_Reference_To (DT_Ptr, Loc), -- DTptr + + Make_Integer_Literal (Loc, DT_Position (Prim)), -- Position + + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (Prim, Loc), + Attribute_Name => Name_Address))); + end Fill_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; + + ------------- + -- 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_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'); + + DT : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT); + DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr); + 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); + + I_Depth : Int; + Generalized_Tag : Entity_Id; + Size_Expr_Node : Node_Id; + Old_Tag : Node_Id; + Old_TSD : Node_Id; + + begin + if Is_CPP_Class (Root_Type (Typ)) then + Generalized_Tag := RTE (RE_Vtable_Ptr); + else + Generalized_Tag := RTE (RE_Tag); + 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); + + 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, + DT_Entry_Count (Tag_Component (Typ))))); + + 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); Ada case + -- or + -- DT_Ptr : Vtable_Ptr := Vtable_Ptr!(DT'Address); CPP case + + 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_Attribute_Reference (Loc, + Prefix => New_Reference_To (DT, Loc), + Attribute_Name => Name_Address)))); + + -- 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 + + Set_Access_Disp_Table (Typ, DT_Ptr); + + -- 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; + + -- Generate code to create the storage for the type specific data object + + -- TSD: Storage_Array (1..TSD_Prologue_Size+(1+Idepth)*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_Op_Add (Loc, + Left_Opnd => Make_Integer_Literal (Loc, 1), + Right_Opnd => + Make_Integer_Literal (Loc, I_Depth)))); + + 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 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)))); + + if Typ = Etype (Typ) + or else Is_CPP_Class (Etype (Typ)) + then + Old_Tag := + Unchecked_Convert_To (Generalized_Tag, + Make_Integer_Literal (Loc, 0)); + + Old_TSD := + Unchecked_Convert_To (RTE (RE_Address), + Make_Integer_Literal (Loc, 0)); + + else + Old_Tag := New_Reference_To (Access_Disp_Table (Etype (Typ)), Loc); + Old_TSD := + Make_DT_Access_Action (Typ, + Action => Get_TSD, + Args => New_List ( + New_Reference_To (Access_Disp_Table (Etype (Typ)), Loc))); + end if; + + -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Inherit_DT, + Args => New_List ( + Node1 => Old_Tag, + Node2 => New_Reference_To (DT_Ptr, Loc), + Node3 => Make_Integer_Literal (Loc, + DT_Entry_Count (Tag_Component (Etype (Typ))))))); + + -- Generate: Inherit_TSD (Get_TSD (parent), DT_Ptr); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Inherit_TSD, + Args => New_List ( + Node1 => Old_TSD, + Node2 => New_Reference_To (DT_Ptr, Loc)))); + + -- 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)))); + + -- 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 + -- Generate: Set_RC_Offset (DT_Ptr, -1); + + 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 + Position := Make_Integer_Literal (Loc, -1); + + 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 component + -- 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. + + 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 + if 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) + then + Status := Standard_True; + else + Status := Standard_False; + end if; + + 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; + + -- 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. We skip this in No_Run_Time + -- mode where the External_Tag attribute is not allowed anyway. + + -- Register_Tag (Dt_Ptr); + + if Is_RTE (Generalized_Tag, RE_Tag) + and then not No_Run_Time + 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)); + + 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 : Entity_Id; + Loc : Source_Ptr; + + begin + if Is_CPP_Class (Root_Type (Typ)) then + Action_Name := RTE (CPP_Actions (Action)); + else + Action_Name := RTE (Ada_Actions (Action)); + end if; + + 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; + + ----------------------------------- + -- 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; + + ------------------------- + -- 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 := Tag_Component (Typ); + Adjusted : Boolean := False; + Finalized : Boolean := False; + Parent_EC : Int; + Nb_Prim : Int; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + + begin + + -- Get Entry_Count of the parent + + if Parent_Typ /= Typ + and then DT_Entry_Count (Tag_Component (Parent_Typ)) /= No_Uint + then + Parent_EC := UI_To_Int (DT_Entry_Count (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 := Homonym (Prim); + + begin + 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; + + -- 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. + + else + + Nb_Prim := 0; + Prim_Elmt := First_Prim; + while Present (Prim_Elmt) loop + Nb_Prim := Nb_Prim + 1; + Prim := Node (Prim_Elmt); + Set_DTC_Entity (Prim, The_Tag); + Set_DT_Position (Prim, UI_From_Int (Nb_Prim)); + + if Chars (Prim) = Name_Finalize + and then (Is_Predefined_File_Name + (Unit_File_Name (Current_Sem_Unit)) + or else + not Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Prim)))) + 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 + -- Limited_Controlled inherits a useless Input stream operation + -- from Root_Controlled, which cannot be overridden. + + 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) + and then Chars (Prim) /= Name_uInput + then + Error_Msg_NE ("abstract inherited private operation&" + & " must be overriden", Parent (Typ), Prim); + end if; + Next_Elmt (Prim_Elmt); + end loop; + + 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_DT_Entry_Count (The_Tag, UI_From_Int (Nb_Prim)); + + -- The derived type must have at least as many components than + -- its parent (for root types, the etype points back to itself + -- and the test should not fail) + + pragma Assert ( + DT_Entry_Count (The_Tag) >= + DT_Entry_Count (Tag_Component (Parent_Typ))); + 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; + Decl : Node_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, Name_uInit_Proc); + Param := Make_Defining_Identifier (Loc, Name_X); + Decl := + 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; + +end Exp_Disp; |