| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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; |
