------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ D I S P -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2005 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. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ 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_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 := First_Formal (Subp); begin 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 -- 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) 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 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_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 (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_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 then -- use it directly. Otherwise, the tag must be extracted from -- the controlling object. if Etype (Ctrl_Arg) = RTE (RE_Tag) 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)); New_Call_Name := Unchecked_Convert_To (Subp_Ptr_Typ, Make_DT_Access_Action (Typ, Action => Get_Prim_Op_Address, Args => New_List ( -- Vptr Controlling_Tag, -- 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_Dispatching_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 not RTE_Available (RE_Tag) then Error_Msg_CRT ("tagged types", Typ); return New_List; end if; 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 -- According to the C++ ABI, the base of the vtable is located -- after the following prologue: Offset_To_Top, Typeinfo_Ptr. -- Hence, move the pointer to the base of the vtable down, after -- this prologue. 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 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 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. 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; -- 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 if RTE_Available (RE_Register_Tag) and then Is_RTE (Generalized_Tag, RE_Tag) and then not No_Run_Time_Mode 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 -- -- 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. -- 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 a-tags.ad?) else Nb_Prim := 1; Prim_Elmt := First_Prim; while Present (Prim_Elmt) loop Nb_Prim := Nb_Prim + 1; Prim := Node (Prim_Elmt); Set_DTC_Entity (Prim, The_Tag); if Chars (Prim) = Name_uSize then Set_DT_Position (Prim, Uint_1); Nb_Prim := Nb_Prim - 1; else Set_DT_Position (Prim, UI_From_Int (Nb_Prim)); end if; 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 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; 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 as 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; 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; end Exp_Disp;