-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- 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. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Atree; use Atree;
with Checks; use Checks;
+with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
+with Exp_Atag; use Exp_Atag;
with Exp_Ch7; use Exp_Ch7;
+with Exp_Dbug; use Exp_Dbug;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
-with Fname; use Fname;
+with Freeze; use Freeze;
with Itypes; use Itypes;
with Lib; use Lib;
with Nlists; use Nlists;
with Nmake; use Nmake;
+with Namet; use Namet;
with Opt; use Opt;
+with Output; use Output;
+with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
with Sem_Disp; use Sem_Disp;
+with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
+with Stringt; use Stringt;
+with Targparm; use Targparm;
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_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_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_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_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);
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Default_Prim_Op_Position (E : Entity_Id) return Uint;
+ -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
+ -- of the default primitive operations.
+
+ function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean;
+ -- Returns true if Prim is not a predefined dispatching primitive but it is
+ -- an alias of a predefined dispatching primitive (ie. through a renaming)
function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
-- Check if the type has a private view or if the public view appears
-- in the visible part of a package spec.
+ function Prim_Op_Kind
+ (Prim : Entity_Id;
+ Typ : Entity_Id) return Node_Id;
+ -- Ada 2005 (AI-345): Determine the primitive operation kind of Prim
+ -- according to its type Typ. Return a reference to an RE_Prim_Op_Kind
+ -- enumeration value.
+
+ function Tagged_Kind (T : Entity_Id) return Node_Id;
+ -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
+ -- to an RE_Tagged_Kind enumeration value.
+
+ ------------------------------
+ -- Default_Prim_Op_Position --
+ ------------------------------
+
+ function Default_Prim_Op_Position (E : Entity_Id) return Uint is
+ TSS_Name : TSS_Name_Type;
+
+ begin
+ Get_Name_String (Chars (E));
+ TSS_Name :=
+ TSS_Name_Type
+ (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
+
+ if Chars (E) = Name_uSize then
+ return Uint_1;
+
+ elsif Chars (E) = Name_uAlignment then
+ return Uint_2;
+
+ elsif TSS_Name = TSS_Stream_Read then
+ return Uint_3;
+
+ elsif TSS_Name = TSS_Stream_Write then
+ return Uint_4;
+
+ elsif TSS_Name = TSS_Stream_Input then
+ return Uint_5;
+
+ elsif TSS_Name = TSS_Stream_Output then
+ return Uint_6;
+
+ elsif Chars (E) = Name_Op_Eq then
+ return Uint_7;
+
+ elsif Chars (E) = Name_uAssign then
+ return Uint_8;
+
+ elsif TSS_Name = TSS_Deep_Adjust then
+ return Uint_9;
+
+ elsif TSS_Name = TSS_Deep_Finalize then
+ return Uint_10;
+
+ elsif Ada_Version >= Ada_05 then
+ if Chars (E) = Name_uDisp_Asynchronous_Select then
+ return Uint_11;
+
+ elsif Chars (E) = Name_uDisp_Conditional_Select then
+ return Uint_12;
+
+ elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
+ return Uint_13;
+
+ elsif Chars (E) = Name_uDisp_Get_Task_Id then
+ return Uint_14;
+
+ elsif Chars (E) = Name_uDisp_Timed_Select then
+ return Uint_15;
+ end if;
+ end if;
+
+ raise Program_Error;
+ end Default_Prim_Op_Position;
+
-----------------------------
-- Expand_Dispatching_Call --
-----------------------------
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));
+ Subp : Entity_Id;
CW_Typ : Entity_Id;
New_Call : Node_Id;
New_Call_Name : Node_Id;
-- 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 --
---------------
Res : constant Node_Id := Duplicate_Subexpr (From);
begin
if Is_Access_Type (Etype (From)) then
- return Make_Explicit_Dereference (Sloc (From), Res);
+ return
+ Make_Explicit_Dereference (Sloc (From),
+ Prefix => 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;
+ -- Start of processing for Expand_Dispatching_Call
- Next_Formal (Formal);
- end loop;
- end;
- end if;
+ begin
+ if No_Run_Time_Mode then
+ Error_Msg_CRT ("tagged types", Call_Node);
+ return;
+ end if;
- -- Controlling type not found (should never happen)
+ -- Expand_Dispatching_Call is called directly from the semantics,
+ -- so we need a check to see whether expansion is active before
+ -- proceeding. In addition, there is no need to expand the call
+ -- if we are compiling under restriction No_Dispatching_Calls;
+ -- the semantic analyzer has previously notified the violation
+ -- of this restriction.
- return Empty;
- end Controlling_Type;
+ if not Expander_Active
+ or else Restriction_Active (No_Dispatching_Calls)
+ then
+ return;
+ end if;
- -- Start of processing for Expand_Dispatching_Call
+ -- Set subprogram. If this is an inherited operation that was
+ -- overridden, the body that is being called is its alias.
- begin
- -- If this is an inherited operation that was overridden, the body
- -- that is being called is its alias.
+ Subp := Entity (Name (Call_Node));
if Present (Alias (Subp))
and then Is_Inherited_Operation (Subp)
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
-- 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));
+ if Etype (Ctrl_Arg) = RTE (RE_Tag)
+ or else (RTE_Available (RE_Interface_Tag)
+ and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag))
+ then
+ CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
+
+ -- Class_Wide_Type is applied to the expressions used to initialize
+ -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
+ -- there are cases where the controlling type is resolved to a specific
+ -- type (such as for designated types of arguments such as CW'Access).
elsif Is_Access_Type (Etype (Ctrl_Arg)) then
- CW_Typ := Designated_Type (Etype (Ctrl_Arg));
+ CW_Typ := Class_Wide_Type (Designated_Type (Etype (Ctrl_Arg)));
else
- CW_Typ := Etype (Ctrl_Arg);
+ CW_Typ := Class_Wide_Type (Etype (Ctrl_Arg));
end if;
Typ := Root_Type (CW_Typ);
+ if Ekind (Typ) = E_Incomplete_Type then
+ Typ := Non_Limited_View (Typ);
+ end if;
+
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
end if;
- if Is_CPP_Class (Root_Type (Typ)) then
-
- -- Create a new parameter list with the displaced 'this'
+ -- Dispatching call to C++ primitive. Create a new parameter list
+ -- with no tag checks.
+ if Is_CPP_Class (Typ) then
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) /= First_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;
-
+ Append_To (New_Params, Relocate_Node (Param));
Next_Actual (Param);
end loop;
+ -- Dispatching call to Ada primitive
+
elsif Present (Param_List) then
-- Generate the Tag checks when appropriate
New_Params := New_List;
-
Param := First_Actual (Call_Node);
while Present (Param) loop
-- Generate the appropriate subprogram pointer type
- if Etype (Subp) = Typ then
+ if Etype (Subp) = Typ then
Res_Typ := CW_Typ;
else
Res_Typ := Etype (Subp);
declare
Old_Formal : Entity_Id := First_Formal (Subp);
New_Formal : Entity_Id;
- Extra : Entity_Id;
+ Extra : Entity_Id := Empty;
begin
if Present (Old_Formal) then
Next_Entity (New_Formal);
Next_Actual (Param);
end loop;
+
+ Set_Next_Entity (New_Formal, Empty);
Set_Last_Entity (Subp_Typ, Extra);
+ end if;
- -- 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;
+ -- Now that the explicit formals have been duplicated, any extra
+ -- formals needed by the subprogram must be created.
- Next_Formal (New_Formal);
- end loop;
+ if Present (Extra) then
+ Set_Extra_Formal (Extra, Empty);
end if;
+
+ Create_Extra_Formals (Subp_Typ);
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 the controlling argument is a value of type Ada.Tag or an abstract
+ -- interface class-wide type then use it directly. Otherwise, the tag
+ -- must be extracted from the controlling object.
+
+ if Etype (Ctrl_Arg) = RTE (RE_Tag)
+ or else (RTE_Available (RE_Interface_Tag)
+ and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag))
+ then
+ Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
+
+ -- Extract the tag from an unchecked type conversion. Done to avoid
+ -- the expansion of additional code just to obtain the value of such
+ -- tag because the current management of interface type conversions
+ -- generates in some cases this unchecked type conversion with the
+ -- tag of the object (see Expand_Interface_Conversion).
+
+ elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion
+ and then
+ (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag)
+ or else
+ (RTE_Available (RE_Interface_Tag)
+ and then
+ Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag)))
+ then
+ Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg));
+
+ -- Ada 2005 (AI-251): Abstract interface class-wide type
- if Etype (Ctrl_Arg) = RTE (RE_Tag) then
+ elsif Is_Interface (Etype (Ctrl_Arg))
+ and then Is_Class_Wide_Type (Etype (Ctrl_Arg))
+ then
Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
else
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 (
+ -- Handle dispatching calls to predefined primitives
- -- Vptr
-
- Controlling_Tag,
+ if Is_Predefined_Dispatching_Operation (Subp)
+ or else Is_Predefined_Dispatching_Alias (Subp)
+ then
+ New_Call_Name :=
+ Unchecked_Convert_To (Subp_Ptr_Typ,
+ Build_Get_Predefined_Prim_Op_Address (Loc,
+ Tag_Node => Controlling_Tag,
+ Position => DT_Position (Subp)));
- -- Position
+ -- Handle dispatching calls to user-defined primitives
- Make_Integer_Literal (Loc, DT_Position (Subp)))));
+ else
+ New_Call_Name :=
+ Unchecked_Convert_To (Subp_Ptr_Typ,
+ Build_Get_Prim_Op_Address (Loc,
+ Typ => Find_Dispatching_Type (Subp),
+ Tag_Node => Controlling_Tag,
+ Position => DT_Position (Subp)));
+ end if;
if Nkind (Call_Node) = N_Function_Call then
+
New_Call :=
Make_Function_Call (Loc,
Name => New_Call_Name,
Make_Selected_Component (Loc,
Prefix => New_Value (Param),
Selector_Name =>
- New_Reference_To
- (First_Tag_Component (Typ), Loc)),
+ New_Reference_To (First_Tag_Component (Typ),
+ Loc)),
Right_Opnd =>
Make_Selected_Component (Loc,
Unchecked_Convert_To (Typ,
New_Value (Next_Actual (Param))),
Selector_Name =>
- New_Reference_To
- (First_Tag_Component (Typ), Loc))),
-
+ New_Reference_To (First_Tag_Component (Typ),
+ Loc))),
Right_Opnd => New_Call);
end if;
end if;
Rewrite (Call_Node, New_Call);
- Analyze_And_Resolve (Call_Node, Call_Typ);
+
+ -- Suppress all checks during the analysis of the expanded code
+ -- to avoid the generation of spureous warnings under ZFP run-time.
+
+ Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks);
end Expand_Dispatching_Call;
- -------------
- -- Fill_DT --
- -------------
+ ---------------------------------
+ -- Expand_Interface_Conversion --
+ ---------------------------------
- function Fill_DT_Entry
- (Loc : Source_Ptr;
- Prim : Entity_Id)
- return Node_Id
+ procedure Expand_Interface_Conversion
+ (N : Node_Id;
+ Is_Static : Boolean := True)
is
- Typ : constant Entity_Id := Scope (DTC_Entity (Prim));
- DT_Ptr : constant Entity_Id := Node (First_Elmt
- (Access_Disp_Table (Typ)));
+ Loc : constant Source_Ptr := Sloc (N);
+ Etyp : constant Entity_Id := Etype (N);
+ Operand : constant Node_Id := Expression (N);
+ Operand_Typ : Entity_Id := Etype (Operand);
+ Fent : Entity_Id;
+ Func : Node_Id;
+ Iface_Typ : Entity_Id := Etype (N);
+ Iface_Tag : Entity_Id;
+ New_Itype : Entity_Id;
+ Stats : List_Id;
begin
- return
- Make_DT_Access_Action (Typ,
- Action => Set_Prim_Op_Address,
- Args => New_List (
- New_Reference_To (DT_Ptr, Loc), -- DTptr
+ -- Ada 2005 (AI-345): Handle synchronized interface type derivations
- Make_Integer_Literal (Loc, DT_Position (Prim)), -- Position
+ if Is_Concurrent_Type (Operand_Typ) then
+ Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
+ end if;
- Make_Attribute_Reference (Loc, -- Value
- Prefix => New_Reference_To (Prim, Loc),
- Attribute_Name => Name_Address)));
- end Fill_DT_Entry;
+ -- Handle access types to interfaces
- ---------------------------
- -- Get_Remotely_Callable --
- ---------------------------
+ if Is_Access_Type (Iface_Typ) then
+ Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ));
+ end if;
- function Get_Remotely_Callable (Obj : Node_Id) return Node_Id is
- Loc : constant Source_Ptr := Sloc (Obj);
+ -- Handle class-wide interface types. This conversion can appear
+ -- explicitly in the source code. Example: I'Class (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;
+ if Is_Class_Wide_Type (Iface_Typ) then
+ Iface_Typ := Root_Type (Iface_Typ);
+ end if;
- -------------
- -- Make_DT --
- -------------
+ pragma Assert (not Is_Static
+ or else (not Is_Class_Wide_Type (Iface_Typ)
+ and then Is_Interface (Iface_Typ)));
- function Make_DT (Typ : Entity_Id) return List_Id is
- Loc : constant Source_Ptr := Sloc (Typ);
+ if VM_Target /= No_VM then
- ADT_List : constant Elist_Id := New_Elmt_List;
- 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;
+ -- For VM, just do a conversion ???
- begin
- if not RTE_Available (RE_Tag) then
- Error_Msg_CRT ("tagged types", Typ);
- return New_List;
+ Rewrite (N, Unchecked_Convert_To (Etype (N), N));
+ Analyze (N);
+ return;
end if;
- if Is_CPP_Class (Root_Type (Typ)) then
- Generalized_Tag := RTE (RE_Vtable_Ptr);
- else
- Generalized_Tag := RTE (RE_Tag);
- end if;
+ if not Is_Static then
- -- Dispatch table and related entities are allocated statically
+ -- Give error if configurable run time and Displace not available
- Set_Ekind (DT, E_Variable);
- Set_Is_Statically_Allocated (DT);
+ if not RTE_Available (RE_Displace) then
+ Error_Msg_CRT ("abstract interface types", N);
+ return;
+ end if;
- Set_Ekind (DT_Ptr, E_Variable);
- Set_Is_Statically_Allocated (DT_Ptr);
+ -- Handle conversion of access-to-class-wide interface types. Target
+ -- can be an access to an object or an access to another class-wide
+ -- interface (see -1- and -2- in the following example):
- Set_Ekind (TSD, E_Variable);
- Set_Is_Statically_Allocated (TSD);
+ -- type Iface1_Ref is access all Iface1'Class;
+ -- type Iface2_Ref is access all Iface1'Class;
- Set_Ekind (Exname, E_Variable);
- Set_Is_Statically_Allocated (Exname);
+ -- Acc1 : Iface1_Ref := new ...
+ -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1
+ -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
- Set_Ekind (No_Reg, E_Variable);
- Set_Is_Statically_Allocated (No_Reg);
+ if Is_Access_Type (Operand_Typ) then
+ pragma Assert
+ (Is_Interface (Directly_Designated_Type (Operand_Typ)));
- -- Generate code to create the storage for the Dispatch_Table object:
+ Rewrite (N,
+ Unchecked_Convert_To (Etype (N),
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (RTE (RE_Displace), Loc),
+ Parameter_Associations => New_List (
- -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
- -- for DT'Alignment use Address'Alignment
+ Unchecked_Convert_To (RTE (RE_Address),
+ Relocate_Node (Expression (N))),
- 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 (First_Tag_Component (Typ)))));
+ New_Occurrence_Of
+ (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
+ Loc)))));
- 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))))));
+ Analyze (N);
+ return;
+ end if;
- 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)));
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (RTE (RE_Displace), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Expression (N)),
+ Attribute_Name => Name_Address),
+
+ New_Occurrence_Of
+ (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
+ Loc))));
+
+ Analyze (N);
+
+ -- If the target is a class-wide interface we change the type of the
+ -- data returned by IW_Convert to indicate that this is a dispatching
+ -- call.
+
+ New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
+ Set_Etype (New_Itype, New_Itype);
+ Init_Esize (New_Itype);
+ Init_Size_Align (New_Itype);
+ Set_Directly_Designated_Type (New_Itype, Etyp);
+
+ Rewrite (N, Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (New_Itype,
+ Relocate_Node (N))));
+ Analyze (N);
+ Freeze_Itype (New_Itype, N);
- -- Generate code to create the pointer to the dispatch table
+ return;
+ end if;
- -- DT_Ptr : Tag := Tag!(DT'Address); Ada case
- -- or
- -- DT_Ptr : Vtable_Ptr := Vtable_Ptr!(DT'Address); CPP case
+ Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
+ pragma Assert (Iface_Tag /= Empty);
- -- 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.
+ -- Keep separate access types to interfaces because one internal
+ -- function is used to handle the null value (see following comment)
- 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)))));
+ if not Is_Access_Type (Etype (N)) then
+ Rewrite (N,
+ Unchecked_Convert_To (Etype (N),
+ Make_Selected_Component (Loc,
+ Prefix => Relocate_Node (Expression (N)),
+ Selector_Name =>
+ New_Occurrence_Of (Iface_Tag, Loc))));
- -- Generate code to define the boolean that controls registration, in
- -- order to avoid multiple registrations for tagged types defined in
- -- multiple-called scopes
+ else
+ -- Build internal function to handle the case in which the
+ -- actual is null. If the actual is null returns null because
+ -- no displacement is required; otherwise performs a type
+ -- conversion that will be expanded in the code that returns
+ -- the value of the displaced actual. That is:
+
+ -- function Func (O : Address) return Iface_Typ is
+ -- begin
+ -- if O = Null_Address then
+ -- return null;
+ -- else
+ -- return Iface_Typ!(Operand_Typ!(O).Iface_Tag'Address);
+ -- end if;
+ -- end Func;
+
+ Fent := Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
- 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)));
+ declare
+ Desig_Typ : Entity_Id;
+ begin
+ Desig_Typ := Etype (Expression (N));
- -- Set Access_Disp_Table field to be the dispatch table pointer
+ if Is_Access_Type (Desig_Typ) then
+ Desig_Typ := Directly_Designated_Type (Desig_Typ);
+ end if;
- Append_Elmt (DT_Ptr, ADT_List);
- Set_Access_Disp_Table (Typ, ADT_List);
+ New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
+ Set_Etype (New_Itype, New_Itype);
+ Set_Scope (New_Itype, Fent);
+ Init_Size_Align (New_Itype);
+ Set_Directly_Designated_Type (New_Itype, Desig_Typ);
+ end;
- -- Count ancestors to compute the inheritance depth. For private
- -- extensions, always go to the full view in order to compute the real
- -- inheritance depth.
+ Stats := New_List (
+ Make_Return_Statement (Loc,
+ Unchecked_Convert_To (Etype (N),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => Unchecked_Convert_To (New_Itype,
+ Make_Identifier (Loc, Name_uO)),
+ Selector_Name =>
+ New_Occurrence_Of (Iface_Tag, Loc)),
+ Attribute_Name => Name_Address))));
+
+ -- If the type is null-excluding, no need for the null branch.
+ -- Otherwise we need to check for it and return null.
+
+ if not Can_Never_Be_Null (Etype (N)) then
+ Stats := New_List (
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => Make_Identifier (Loc, Name_uO),
+ Right_Opnd => New_Reference_To
+ (RTE (RE_Null_Address), Loc)),
+
+ Then_Statements => New_List (
+ Make_Return_Statement (Loc,
+ Make_Null (Loc))),
+ Else_Statements => Stats));
+ end if;
- declare
- Parent_Type : Entity_Id := Typ;
- P : Entity_Id;
+ Func :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Fent,
- begin
- I_Depth := 0;
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uO),
+ Parameter_Type =>
+ New_Reference_To (RTE (RE_Address), Loc))),
- loop
- P := Etype (Parent_Type);
+ Result_Definition =>
+ New_Reference_To (Etype (N), Loc)),
- if Is_Private_Type (P) then
- P := Full_View (Base_Type (P));
- end if;
+ Declarations => Empty_List,
- exit when P = Parent_Type;
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stats));
- I_Depth := I_Depth + 1;
- Parent_Type := P;
- end loop;
- end;
+ -- Place function body before the expression containing the
+ -- conversion. We suppress all checks because the body of the
+ -- internally generated function already takes care of the case
+ -- in which the actual is null; therefore there is no need to
+ -- double check that the pointer is not null when the program
+ -- executes the alternative that performs the type conversion).
- -- Generate code to create the storage for the type specific data object
+ Insert_Action (N, Func, Suppress => All_Checks);
- -- TSD: Storage_Array (1..TSD_Prologue_Size+(1+Idepth)*TSD_Entry_Size);
- -- for TSD'Alignment use Address'Alignment
+ if Is_Access_Type (Etype (Expression (N))) then
- 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))));
+ -- Generate: Operand_Typ!(Expression.all)'Address
- 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))))));
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (Fent, Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Unchecked_Convert_To (Operand_Typ,
+ Make_Explicit_Dereference (Loc,
+ Relocate_Node (Expression (N)))),
+ Attribute_Name => Name_Address))));
- 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)));
+ else
+ -- Generate: Operand_Typ!(Expression)'Address
+
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (Fent, Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Unchecked_Convert_To (Operand_Typ,
+ Relocate_Node (Expression (N))),
+ Attribute_Name => Name_Address))));
+ end if;
+ end if;
- -- Generate code to put the Address of the TSD in the dispatch table
- -- Set_TSD (DT_Ptr, TSD);
+ Analyze (N);
+ end Expand_Interface_Conversion;
+
+ ------------------------------
+ -- Expand_Interface_Actuals --
+ ------------------------------
+
+ procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Call_Node);
+ Actual : Node_Id;
+ Actual_Dup : Node_Id;
+ Actual_Typ : Entity_Id;
+ Anon : Entity_Id;
+ Conversion : Node_Id;
+ Formal : Entity_Id;
+ Formal_Typ : Entity_Id;
+ Subp : Entity_Id;
+ Nam : Name_Id;
+ Formal_DDT : Entity_Id;
+ Actual_DDT : Entity_Id;
- 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))));
+ begin
+ -- This subprogram is called directly from the semantics, so we need a
+ -- check to see whether expansion is active before proceeding.
- if Typ = Etype (Typ)
- or else Is_CPP_Class (Etype (Typ))
- then
- Old_Tag :=
- Unchecked_Convert_To (Generalized_Tag,
- Make_Integer_Literal (Loc, 0));
+ if not Expander_Active then
+ return;
+ end if;
+
+ -- Call using access to subprogram with explicit dereference
- Old_TSD :=
- Unchecked_Convert_To (RTE (RE_Address),
- Make_Integer_Literal (Loc, 0));
+ if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
+ Subp := Etype (Name (Call_Node));
+
+ -- Normal case
else
- Old_Tag :=
- New_Reference_To
- (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
- Old_TSD :=
- Make_DT_Access_Action (Typ,
- Action => Get_TSD,
- Args => New_List (
- New_Reference_To
- (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc)));
+ Subp := Entity (Name (Call_Node));
end if;
- -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
+ -- Ada 2005 (AI-251): Look for interface type formals to force "this"
+ -- displacement
- 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 (First_Tag_Component (Etype (Typ)))))));
+ Formal := First_Formal (Subp);
+ Actual := First_Actual (Call_Node);
+ while Present (Formal) loop
+ Formal_Typ := Etype (Formal);
- -- Generate: Inherit_TSD (Get_TSD (parent), DT_Ptr);
+ if Ekind (Formal_Typ) = E_Record_Type_With_Private then
+ Formal_Typ := Full_View (Formal_Typ);
+ end if;
- 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))));
+ if Is_Access_Type (Formal_Typ) then
+ Formal_DDT := Directly_Designated_Type (Formal_Typ);
+ end if;
- -- Generate: Exname : constant String := full_qualified_name (typ);
- -- The type itself may be an anonymous parent type, so use the first
- -- subtype to have a user-recognizable name.
+ Actual_Typ := Etype (Actual);
- 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)))));
+ if Is_Access_Type (Actual_Typ) then
+ Actual_DDT := Directly_Designated_Type (Actual_Typ);
+ end if;
- -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address);
+ if Is_Interface (Formal_Typ)
+ and then Is_Class_Wide_Type (Formal_Typ)
+ then
+ -- No need to displace the pointer if the type of the actual
+ -- coindices with the type of the formal.
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Set_Expanded_Name,
- Args => New_List (
- Node1 => New_Reference_To (DT_Ptr, Loc),
- Node2 =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Exname, Loc),
- Attribute_Name => Name_Address))));
+ if Actual_Typ = Formal_Typ then
+ null;
- -- 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.
+ -- No need to displace the pointer if the interface type is
+ -- a parent of the type of the actual because in this case the
+ -- interface primitives are located in the primary dispatch table.
- declare
- Position : Node_Id;
+ elsif Is_Parent (Formal_Typ, Actual_Typ) then
+ null;
- begin
- if not Has_Controlled_Component (Typ) then
- Position := Make_Integer_Literal (Loc, 0);
+ -- Implicit conversion to the class-wide formal type to force
+ -- the displacement of the pointer.
- 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);
+ Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
+ Rewrite (Actual, Conversion);
+ Analyze_And_Resolve (Actual, Formal_Typ);
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;
+ -- Access to class-wide interface type
- -- Generate: Set_Remotely_Callable (DT_Ptr, Status);
- -- where Status is described in E.4 (18)
+ elsif Is_Access_Type (Formal_Typ)
+ and then Is_Interface (Formal_DDT)
+ and then Is_Class_Wide_Type (Formal_DDT)
+ and then Interface_Present_In_Ancestor
+ (Typ => Actual_DDT,
+ Iface => Etype (Formal_DDT))
+ then
+ -- Handle attributes 'Access and 'Unchecked_Access
- declare
- Status : Entity_Id;
+ if Nkind (Actual) = N_Attribute_Reference
+ and then
+ (Attribute_Name (Actual) = Name_Access
+ or else Attribute_Name (Actual) = Name_Unchecked_Access)
+ then
+ Nam := Attribute_Name (Actual);
- 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));
+ Conversion := Convert_To (Formal_DDT, Prefix (Actual));
+ Rewrite (Actual, Conversion);
+ Analyze_And_Resolve (Actual, Formal_DDT);
- 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;
+ Rewrite (Actual,
+ Unchecked_Convert_To (Formal_Typ,
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Actual),
+ Attribute_Name => Nam)));
+ Analyze_And_Resolve (Actual, Formal_Typ);
- -- Generate: Set_External_Tag (DT_Ptr, exname'Address);
- -- Should be the external name not the qualified name???
+ -- No need to displace the pointer if the type of the actual
+ -- coincides with the type of the formal.
- 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))));
+ elsif Actual_DDT = Formal_DDT then
+ null;
- -- Generate code to register the Tag in the External_Tag hash
- -- table for the pure Ada type only.
+ -- No need to displace the pointer if the interface type is
+ -- a parent of the type of the actual because in this case the
+ -- interface primitives are located in the primary dispatch table.
- -- Register_Tag (Dt_Ptr);
+ elsif Is_Parent (Formal_DDT, Actual_DDT) then
+ null;
- -- Skip this if routine not available, or in No_Run_Time mode
+ else
+ Actual_Dup := Relocate_Node (Actual);
- 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;
+ if From_With_Type (Actual_Typ) then
- -- Generate:
- -- if No_Reg then
- -- <elab_code>
- -- No_Reg := False;
- -- end if;
+ -- If the type of the actual parameter comes from a limited
+ -- with-clause and the non-limited view is already available
+ -- we replace the anonymous access type by a duplicate decla
+ -- ration whose designated type is the non-limited view
- Append_To (Elab_Code,
- Make_Assignment_Statement (Loc,
- Name => New_Reference_To (No_Reg, Loc),
- Expression => New_Reference_To (Standard_False, Loc)));
+ if Ekind (Actual_DDT) = E_Incomplete_Type
+ and then Present (Non_Limited_View (Actual_DDT))
+ then
+ Anon := New_Copy (Actual_Typ);
- Append_To (Result,
- Make_Implicit_If_Statement (Typ,
- Condition => New_Reference_To (No_Reg, Loc),
- Then_Statements => Elab_Code));
+ if Is_Itype (Anon) then
+ Set_Scope (Anon, Current_Scope);
+ end if;
- return Result;
- end Make_DT;
+ Set_Directly_Designated_Type (Anon,
+ Non_Limited_View (Actual_DDT));
+ Set_Etype (Actual_Dup, Anon);
- ---------------------------
- -- Make_DT_Access_Action --
- ---------------------------
+ elsif Is_Class_Wide_Type (Actual_DDT)
+ and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type
+ and then Present (Non_Limited_View (Etype (Actual_DDT)))
+ then
+ Anon := New_Copy (Actual_Typ);
+
+ if Is_Itype (Anon) then
+ Set_Scope (Anon, Current_Scope);
+ end if;
+
+ Set_Directly_Designated_Type (Anon,
+ New_Copy (Actual_DDT));
+ Set_Class_Wide_Type (Directly_Designated_Type (Anon),
+ New_Copy (Class_Wide_Type (Actual_DDT)));
+ Set_Etype (Directly_Designated_Type (Anon),
+ Non_Limited_View (Etype (Actual_DDT)));
+ Set_Etype (
+ Class_Wide_Type (Directly_Designated_Type (Anon)),
+ Non_Limited_View (Etype (Actual_DDT)));
+ Set_Etype (Actual_Dup, Anon);
+ end if;
+ end if;
+
+ Conversion := Convert_To (Formal_Typ, Actual_Dup);
+ Rewrite (Actual, Conversion);
+ Analyze_And_Resolve (Actual, Formal_Typ);
+ end if;
+ end if;
+
+ Next_Actual (Actual);
+ Next_Formal (Formal);
+ end loop;
+ end Expand_Interface_Actuals;
+
+ ----------------------------
+ -- Expand_Interface_Thunk --
+ ----------------------------
+
+ procedure Expand_Interface_Thunk
+ (N : Node_Id;
+ Thunk_Alias : Entity_Id;
+ Thunk_Id : out Entity_Id;
+ Thunk_Code : out Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Actuals : constant List_Id := New_List;
+ Decl : constant List_Id := New_List;
+ Formals : constant List_Id := New_List;
+
+ Controlling_Typ : Entity_Id;
+ Decl_1 : Node_Id;
+ Decl_2 : Node_Id;
+ Formal : Node_Id;
+ Target : Entity_Id;
+ Target_Formal : Entity_Id;
+
+ begin
+ Thunk_Id := Empty;
+ Thunk_Code := Empty;
+
+ -- Give message if configurable run-time and Offset_To_Top unavailable
+
+ if not RTE_Available (RE_Offset_To_Top) then
+ Error_Msg_CRT ("abstract interface types", N);
+ return;
+ end if;
+
+ -- Traverse the list of alias to find the final target
+
+ Target := Thunk_Alias;
+ while Present (Alias (Target)) loop
+ Target := Alias (Target);
+ end loop;
+
+ -- In case of primitives that are functions without formals and
+ -- a controlling result there is no need to build the thunk.
+
+ if not Present (First_Formal (Target)) then
+ pragma Assert (Ekind (Target) = E_Function
+ and then Has_Controlling_Result (Target));
+ return;
+ end if;
+
+ -- Duplicate the formals
+
+ Formal := First_Formal (Target);
+ while Present (Formal) loop
+ Append_To (Formals,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Sloc (Formal),
+ Chars => Chars (Formal)),
+ In_Present => In_Present (Parent (Formal)),
+ Out_Present => Out_Present (Parent (Formal)),
+ Parameter_Type =>
+ New_Reference_To (Etype (Formal), Loc),
+ Expression => New_Copy_Tree (Expression (Parent (Formal)))));
+
+ Next_Formal (Formal);
+ end loop;
+
+ if Ekind (First_Formal (Target)) = E_In_Parameter
+ and then Ekind (Etype (First_Formal (Target)))
+ = E_Anonymous_Access_Type
+ then
+ Controlling_Typ :=
+ Directly_Designated_Type (Etype (First_Formal (Target)));
+ else
+ Controlling_Typ := Etype (First_Formal (Target));
+ end if;
+
+ Target_Formal := First_Formal (Target);
+ Formal := First (Formals);
+ while Present (Formal) loop
+ if Ekind (Target_Formal) = E_In_Parameter
+ and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
+ and then Directly_Designated_Type (Etype (Target_Formal))
+ = Controlling_Typ
+ then
+ -- Generate:
+
+ -- type T is access all <<type of the first formal>>
+ -- S1 := Storage_Offset!(formal)
+ -- - Offset_To_Top (Formal.Tag)
+
+ -- ... and the first actual of the call is generated as T!(S1)
+
+ Decl_2 :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('T')),
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Null_Exclusion_Present => False,
+ Constant_Present => False,
+ Subtype_Indication =>
+ New_Reference_To
+ (Directly_Designated_Type
+ (Etype (Target_Formal)), Loc)));
+
+ Decl_1 :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('S')),
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Storage_Offset), Loc),
+ Expression =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd =>
+ Unchecked_Convert_To
+ (RTE (RE_Storage_Offset),
+ New_Reference_To (Defining_Identifier (Formal), Loc)),
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Offset_To_Top), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To
+ (RTE (RE_Address),
+ New_Reference_To
+ (Defining_Identifier (Formal), Loc))))));
+
+ Append_To (Decl, Decl_2);
+ Append_To (Decl, Decl_1);
+
+ -- Reference the new first actual
+
+ Append_To (Actuals,
+ Unchecked_Convert_To
+ (Defining_Identifier (Decl_2),
+ New_Reference_To (Defining_Identifier (Decl_1), Loc)));
+
+ elsif Etype (Target_Formal) = Controlling_Typ then
+ -- Generate:
+
+ -- S1 := Storage_Offset!(Formal'Address)
+ -- - Offset_To_Top (Formal.Tag)
+ -- S2 := Tag_Ptr!(S3)
+
+ Decl_1 :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Storage_Offset), Loc),
+ Expression =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd =>
+ Unchecked_Convert_To
+ (RTE (RE_Storage_Offset),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To
+ (Defining_Identifier (Formal), Loc),
+ Attribute_Name => Name_Address)),
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Offset_To_Top), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To
+ (Defining_Identifier (Formal), Loc),
+ Attribute_Name => Name_Address)))));
+
+ Decl_2 :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (RTE (RE_Addr_Ptr), Loc),
+ Expression =>
+ Unchecked_Convert_To
+ (RTE (RE_Addr_Ptr),
+ New_Reference_To (Defining_Identifier (Decl_1), Loc)));
+
+ Append_To (Decl, Decl_1);
+ Append_To (Decl, Decl_2);
+
+ -- Reference the new first actual
+
+ Append_To (Actuals,
+ Unchecked_Convert_To
+ (Etype (First_Entity (Target)),
+ Make_Explicit_Dereference (Loc,
+ New_Reference_To (Defining_Identifier (Decl_2), Loc))));
+
+ -- No special management required for this actual
+
+ else
+ Append_To (Actuals,
+ New_Reference_To (Defining_Identifier (Formal), Loc));
+ end if;
+
+ Next_Formal (Target_Formal);
+ Next (Formal);
+ end loop;
+
+ Thunk_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('T'));
+
+ if Ekind (Target) = E_Procedure then
+ Thunk_Code :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Thunk_Id,
+ Parameter_Specifications => Formals),
+ Declarations => Decl,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Target, Loc),
+ Parameter_Associations => Actuals))));
+
+ else pragma Assert (Ekind (Target) = E_Function);
+
+ Thunk_Code :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Thunk_Id,
+ Parameter_Specifications => Formals,
+ Result_Definition =>
+ New_Copy (Result_Definition (Parent (Target)))),
+ Declarations => Decl,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Return_Statement (Loc,
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Target, Loc),
+ Parameter_Associations => Actuals)))));
+ end if;
+ end Expand_Interface_Thunk;
+
+ -------------------------------------
+ -- Is_Predefined_Dispatching_Alias --
+ -------------------------------------
+
+ function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean
+ is
+ E : Entity_Id;
+
+ begin
+ if not Is_Predefined_Dispatching_Operation (Prim)
+ and then Present (Alias (Prim))
+ then
+ E := Prim;
+ while Present (Alias (E)) loop
+ E := Alias (E);
+ end loop;
+
+ if Is_Predefined_Dispatching_Operation (E) then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Is_Predefined_Dispatching_Alias;
+
+ ----------------------------------------
+ -- Make_Disp_Asynchronous_Select_Body --
+ ----------------------------------------
+
+ function Make_Disp_Asynchronous_Select_Body
+ (Typ : Entity_Id) return Node_Id
+ is
+ Com_Block : Entity_Id;
+ Conc_Typ : Entity_Id := Empty;
+ Decls : constant List_Id := New_List;
+ DT_Ptr : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Stmts : constant List_Id := New_List;
+
+ begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
+ -- Null body is generated for interface types
+
+ if Is_Interface (Typ) then
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Asynchronous_Select_Spec (Typ),
+ Declarations =>
+ New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ New_List (Make_Null_Statement (Loc))));
+ end if;
+
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+
+ if Is_Concurrent_Record_Type (Typ) then
+ Conc_Typ := Corresponding_Concurrent_Type (Typ);
+
+ -- Generate:
+ -- I : Integer := Get_Entry_Index (tag! (<type>VP), S);
+
+ -- where I will be used to capture the entry index of the primitive
+ -- wrapper at position S.
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uI),
+ Object_Definition =>
+ New_Reference_To (Standard_Integer, Loc),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Identifier (Loc, Name_uS)))));
+
+ if Ekind (Conc_Typ) = E_Protected_Type then
+
+ -- Generate:
+ -- Com_Block : Communication_Block;
+
+ Com_Block :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Com_Block,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Communication_Block), Loc)));
+
+ -- Generate:
+ -- Protected_Entry_Call (
+ -- T._object'access,
+ -- protected_entry_index! (I),
+ -- P,
+ -- Asynchronous_Call,
+ -- Com_Block);
+
+ -- where T is the protected object, I is the entry index, P are
+ -- the wrapped parameters and B is the name of the communication
+ -- block.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+
+ Make_Attribute_Reference (Loc, -- T._object'access
+ Attribute_Name =>
+ Name_Unchecked_Access,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uObject))),
+
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
+
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ New_Reference_To ( -- Asynchronous_Call
+ RTE (RE_Asynchronous_Call), Loc),
+
+ New_Reference_To (Com_Block, Loc)))); -- comm block
+
+ -- Generate:
+ -- B := Dummy_Communication_Bloc (Com_Block);
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uB),
+ Expression =>
+ Make_Unchecked_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Reference_To (
+ RTE (RE_Dummy_Communication_Block), Loc),
+ Expression =>
+ New_Reference_To (Com_Block, Loc))));
+
+ else
+ pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
+
+ -- Generate:
+ -- Protected_Entry_Call (
+ -- T._task_id,
+ -- task_entry_index! (I),
+ -- P,
+ -- Conditional_Call,
+ -- F);
+
+ -- where T is the task object, I is the entry index, P are the
+ -- wrapped parameters and F is the status flag.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+
+ Make_Selected_Component (Loc, -- T._task_id
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTask_Id)),
+
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
+
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ New_Reference_To ( -- Asynchronous_Call
+ RTE (RE_Asynchronous_Call), Loc),
+ Make_Identifier (Loc, Name_uF)))); -- status flag
+ end if;
+ end if;
+
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Asynchronous_Select_Spec (Typ),
+ Declarations =>
+ Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+ end Make_Disp_Asynchronous_Select_Body;
+
+ ----------------------------------------
+ -- Make_Disp_Asynchronous_Select_Spec --
+ ----------------------------------------
+
+ function Make_Disp_Asynchronous_Select_Spec
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Def_Id : constant Node_Id :=
+ Make_Defining_Identifier (Loc,
+ Name_uDisp_Asynchronous_Select);
+ Params : constant List_Id := New_List;
+
+ begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
+ -- T : in out Typ; -- Object parameter
+ -- S : Integer; -- Primitive operation slot
+ -- P : Address; -- Wrapped parameters
+ -- B : out Dummy_Communication_Block; -- Communication block dummy
+ -- F : out Boolean; -- Status flag
+
+ Append_List_To (Params, New_List (
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uT),
+ Parameter_Type =>
+ New_Reference_To (Typ, Loc),
+ In_Present => True,
+ Out_Present => True),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uS),
+ Parameter_Type =>
+ New_Reference_To (Standard_Integer, Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uP),
+ Parameter_Type =>
+ New_Reference_To (RTE (RE_Address), Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uB),
+ Parameter_Type =>
+ New_Reference_To (RTE (RE_Dummy_Communication_Block), Loc),
+ Out_Present => True),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uF),
+ Parameter_Type =>
+ New_Reference_To (Standard_Boolean, Loc),
+ Out_Present => True)));
+
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Def_Id,
+ Parameter_Specifications => Params);
+ end Make_Disp_Asynchronous_Select_Spec;
+
+ ---------------------------------------
+ -- Make_Disp_Conditional_Select_Body --
+ ---------------------------------------
+
+ function Make_Disp_Conditional_Select_Body
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Blk_Nam : Entity_Id;
+ Conc_Typ : Entity_Id := Empty;
+ Decls : constant List_Id := New_List;
+ DT_Ptr : Entity_Id;
+ Stmts : constant List_Id := New_List;
+
+ begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
+ -- Null body is generated for interface types
+
+ if Is_Interface (Typ) then
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Conditional_Select_Spec (Typ),
+ Declarations =>
+ No_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ New_List (Make_Null_Statement (Loc))));
+ end if;
+
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+
+ if Is_Concurrent_Record_Type (Typ) then
+ Conc_Typ := Corresponding_Concurrent_Type (Typ);
+
+ -- Generate:
+ -- I : Integer;
+
+ -- where I will be used to capture the entry index of the primitive
+ -- wrapper at position S.
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uI),
+ Object_Definition =>
+ New_Reference_To (Standard_Integer, Loc)));
+
+ -- Generate:
+ -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
+
+ -- if C = POK_Procedure
+ -- or else C = POK_Protected_Procedure
+ -- or else C = POK_Task_Procedure;
+ -- then
+ -- F := True;
+ -- return;
+ -- end if;
+
+ Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts);
+
+ -- Generate:
+ -- Bnn : Communication_Block;
+
+ -- where Bnn is the name of the communication block used in
+ -- the call to Protected_Entry_Call.
+
+ Blk_Nam := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Blk_Nam,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Communication_Block), Loc)));
+
+ -- Generate:
+ -- I := Get_Entry_Index (tag! (<type>VP), S);
+
+ -- I is the entry index and S is the dispatch table slot
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uI),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Identifier (Loc, Name_uS)))));
+
+ if Ekind (Conc_Typ) = E_Protected_Type then
+
+ -- Generate:
+ -- Protected_Entry_Call (
+ -- T._object'access,
+ -- protected_entry_index! (I),
+ -- P,
+ -- Conditional_Call,
+ -- Bnn);
+
+ -- where T is the protected object, I is the entry index, P are
+ -- the wrapped parameters and Bnn is the name of the communication
+ -- block.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+
+ Make_Attribute_Reference (Loc, -- T._object'access
+ Attribute_Name =>
+ Name_Unchecked_Access,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uObject))),
+
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
+
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ New_Reference_To ( -- Conditional_Call
+ RTE (RE_Conditional_Call), Loc),
+ New_Reference_To ( -- Bnn
+ Blk_Nam, Loc))));
+
+ -- Generate:
+ -- F := not Cancelled (Bnn);
+
+ -- where F is the success flag. The status of Cancelled is negated
+ -- in order to match the behaviour of the version for task types.
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uF),
+ Expression =>
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Cancelled), Loc),
+ Parameter_Associations =>
+ New_List (
+ New_Reference_To (Blk_Nam, Loc))))));
+ else
+ pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
+
+ -- Generate:
+ -- Protected_Entry_Call (
+ -- T._task_id,
+ -- task_entry_index! (I),
+ -- P,
+ -- Conditional_Call,
+ -- F);
+
+ -- where T is the task object, I is the entry index, P are the
+ -- wrapped parameters and F is the status flag.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+
+ Make_Selected_Component (Loc, -- T._task_id
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTask_Id)),
+
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
+
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ New_Reference_To ( -- Conditional_Call
+ RTE (RE_Conditional_Call), Loc),
+ Make_Identifier (Loc, Name_uF)))); -- status flag
+ end if;
+ end if;
+
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Conditional_Select_Spec (Typ),
+ Declarations =>
+ Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+ end Make_Disp_Conditional_Select_Body;
+
+ ---------------------------------------
+ -- Make_Disp_Conditional_Select_Spec --
+ ---------------------------------------
+
+ function Make_Disp_Conditional_Select_Spec
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Def_Id : constant Node_Id :=
+ Make_Defining_Identifier (Loc,
+ Name_uDisp_Conditional_Select);
+ Params : constant List_Id := New_List;
+
+ begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
+ -- T : in out Typ; -- Object parameter
+ -- S : Integer; -- Primitive operation slot
+ -- P : Address; -- Wrapped parameters
+ -- C : out Prim_Op_Kind; -- Call kind
+ -- F : out Boolean; -- Status flag
+
+ Append_List_To (Params, New_List (
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uT),
+ Parameter_Type =>
+ New_Reference_To (Typ, Loc),
+ In_Present => True,
+ Out_Present => True),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uS),
+ Parameter_Type =>
+ New_Reference_To (Standard_Integer, Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uP),
+ Parameter_Type =>
+ New_Reference_To (RTE (RE_Address), Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uC),
+ Parameter_Type =>
+ New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
+ Out_Present => True),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uF),
+ Parameter_Type =>
+ New_Reference_To (Standard_Boolean, Loc),
+ Out_Present => True)));
+
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Def_Id,
+ Parameter_Specifications => Params);
+ end Make_Disp_Conditional_Select_Spec;
+
+ -------------------------------------
+ -- Make_Disp_Get_Prim_Op_Kind_Body --
+ -------------------------------------
+
+ function Make_Disp_Get_Prim_Op_Kind_Body
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ DT_Ptr : Entity_Id;
+
+ begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
+ if Is_Interface (Typ) then
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
+ Declarations =>
+ New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ New_List (Make_Null_Statement (Loc))));
+ end if;
+
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+
+ -- Generate:
+ -- C := get_prim_op_kind (tag! (<type>VP), S);
+
+ -- where C is the out parameter capturing the call kind and S is the
+ -- dispatch table slot number.
+
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
+ Declarations =>
+ New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uC),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Get_Prim_Op_Kind), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Identifier (Loc, Name_uS)))))));
+ end Make_Disp_Get_Prim_Op_Kind_Body;
+
+ -------------------------------------
+ -- Make_Disp_Get_Prim_Op_Kind_Spec --
+ -------------------------------------
+
+ function Make_Disp_Get_Prim_Op_Kind_Spec
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Def_Id : constant Node_Id :=
+ Make_Defining_Identifier (Loc,
+ Name_uDisp_Get_Prim_Op_Kind);
+ Params : constant List_Id := New_List;
+
+ begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
+ -- T : in out Typ; -- Object parameter
+ -- S : Integer; -- Primitive operation slot
+ -- C : out Prim_Op_Kind; -- Call kind
+
+ Append_List_To (Params, New_List (
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uT),
+ Parameter_Type =>
+ New_Reference_To (Typ, Loc),
+ In_Present => True,
+ Out_Present => True),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uS),
+ Parameter_Type =>
+ New_Reference_To (Standard_Integer, Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uC),
+ Parameter_Type =>
+ New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
+ Out_Present => True)));
+
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Def_Id,
+ Parameter_Specifications => Params);
+ end Make_Disp_Get_Prim_Op_Kind_Spec;
+
+ --------------------------------
+ -- Make_Disp_Get_Task_Id_Body --
+ --------------------------------
+
+ function Make_Disp_Get_Task_Id_Body
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Ret : Node_Id;
+
+ begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
+ if Is_Concurrent_Record_Type (Typ)
+ and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type
+ then
+ -- Generate:
+ -- return To_Address (_T._task_id);
+
+ Ret :=
+ Make_Return_Statement (Loc,
+ Expression =>
+ Make_Unchecked_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Address), Loc),
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTask_Id))));
+
+ -- A null body is constructed for non-task types
+
+ else
+ -- Generate:
+ -- return Null_Address;
+
+ Ret :=
+ Make_Return_Statement (Loc,
+ Expression =>
+ New_Reference_To (RTE (RE_Null_Address), Loc));
+ end if;
+
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Get_Task_Id_Spec (Typ),
+ Declarations =>
+ New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ New_List (Ret)));
+ end Make_Disp_Get_Task_Id_Body;
+
+ --------------------------------
+ -- Make_Disp_Get_Task_Id_Spec --
+ --------------------------------
+
+ function Make_Disp_Get_Task_Id_Spec
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+
+ begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
+ return
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id),
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uT),
+ Parameter_Type =>
+ New_Reference_To (Typ, Loc))),
+ Result_Definition =>
+ New_Reference_To (RTE (RE_Address), Loc));
+ end Make_Disp_Get_Task_Id_Spec;
+
+ ---------------------------------
+ -- Make_Disp_Timed_Select_Body --
+ ---------------------------------
+
+ function Make_Disp_Timed_Select_Body
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Conc_Typ : Entity_Id := Empty;
+ Decls : constant List_Id := New_List;
+ DT_Ptr : Entity_Id;
+ Stmts : constant List_Id := New_List;
+
+ begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
+ -- Null body is generated for interface types
+
+ if Is_Interface (Typ) then
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Timed_Select_Spec (Typ),
+ Declarations =>
+ New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ New_List (Make_Null_Statement (Loc))));
+ end if;
+
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+
+ if Is_Concurrent_Record_Type (Typ) then
+ Conc_Typ := Corresponding_Concurrent_Type (Typ);
+
+ -- Generate:
+ -- I : Integer;
+
+ -- where I will be used to capture the entry index of the primitive
+ -- wrapper at position S.
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uI),
+ Object_Definition =>
+ New_Reference_To (Standard_Integer, Loc)));
+
+ -- Generate:
+ -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
+
+ -- if C = POK_Procedure
+ -- or else C = POK_Protected_Procedure
+ -- or else C = POK_Task_Procedure;
+ -- then
+ -- F := True;
+ -- return;
+ -- end if;
+
+ Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts);
+
+ -- Generate:
+ -- I := Get_Entry_Index (tag! (<type>VP), S);
+
+ -- I is the entry index and S is the dispatch table slot
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uI),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Identifier (Loc, Name_uS)))));
+
+ if Ekind (Conc_Typ) = E_Protected_Type then
+
+ -- Generate:
+ -- Timed_Protected_Entry_Call (
+ -- T._object'access,
+ -- protected_entry_index! (I),
+ -- P,
+ -- D,
+ -- M,
+ -- F);
+
+ -- where T is the protected object, I is the entry index, P are
+ -- the wrapped parameters, D is the delay amount, M is the delay
+ -- mode and F is the status flag.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+
+ Make_Attribute_Reference (Loc, -- T._object'access
+ Attribute_Name =>
+ Name_Unchecked_Access,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uObject))),
+
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
+
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ Make_Identifier (Loc, Name_uD), -- delay
+ Make_Identifier (Loc, Name_uM), -- delay mode
+ Make_Identifier (Loc, Name_uF)))); -- status flag
+
+ else
+ pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
+
+ -- Generate:
+ -- Timed_Task_Entry_Call (
+ -- T._task_id,
+ -- task_entry_index! (I),
+ -- P,
+ -- D,
+ -- M,
+ -- F);
+
+ -- where T is the task object, I is the entry index, P are the
+ -- wrapped parameters, D is the delay amount, M is the delay
+ -- mode and F is the status flag.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+
+ Make_Selected_Component (Loc, -- T._task_id
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTask_Id)),
+
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
+
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ Make_Identifier (Loc, Name_uD), -- delay
+ Make_Identifier (Loc, Name_uM), -- delay mode
+ Make_Identifier (Loc, Name_uF)))); -- status flag
+ end if;
+ end if;
+
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Timed_Select_Spec (Typ),
+ Declarations =>
+ Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+ end Make_Disp_Timed_Select_Body;
+
+ ---------------------------------
+ -- Make_Disp_Timed_Select_Spec --
+ ---------------------------------
+
+ function Make_Disp_Timed_Select_Spec
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Def_Id : constant Node_Id :=
+ Make_Defining_Identifier (Loc,
+ Name_uDisp_Timed_Select);
+ Params : constant List_Id := New_List;
+
+ begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
+ -- T : in out Typ; -- Object parameter
+ -- S : Integer; -- Primitive operation slot
+ -- P : Address; -- Wrapped parameters
+ -- D : Duration; -- Delay
+ -- M : Integer; -- Delay Mode
+ -- C : out Prim_Op_Kind; -- Call kind
+ -- F : out Boolean; -- Status flag
+
+ Append_List_To (Params, New_List (
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uT),
+ Parameter_Type =>
+ New_Reference_To (Typ, Loc),
+ In_Present => True,
+ Out_Present => True),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uS),
+ Parameter_Type =>
+ New_Reference_To (Standard_Integer, Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uP),
+ Parameter_Type =>
+ New_Reference_To (RTE (RE_Address), Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uD),
+ Parameter_Type =>
+ New_Reference_To (Standard_Duration, Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uM),
+ Parameter_Type =>
+ New_Reference_To (Standard_Integer, Loc)),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uC),
+ Parameter_Type =>
+ New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
+ Out_Present => True)));
+
+ Append_To (Params,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uF),
+ Parameter_Type =>
+ New_Reference_To (Standard_Boolean, Loc),
+ Out_Present => True));
+
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Def_Id,
+ Parameter_Specifications => Params);
+ end Make_Disp_Timed_Select_Spec;
+
+ -------------
+ -- Make_DT --
+ -------------
+
+ -- The frontend supports two models for expanding dispatch tables
+ -- associated with library-level defined tagged types: statically
+ -- and non-statically allocated dispatch tables. In the former case
+ -- the object containing the dispatch table is constant and it is
+ -- initialized by means of a positional aggregate. In the latter case,
+ -- the object containing the dispatch table is a variable which is
+ -- initialized by means of assignments.
+
+ -- In case of locally defined tagged types, the object containing the
+ -- object containing the dispatch table is always a variable (instead
+ -- of a constant). This is currently required to give support to late
+ -- overriding of primitives. For example:
+
+ -- procedure Example is
+ -- package Pkg is
+ -- type T1 is tagged null record;
+ -- procedure Prim (O : T1);
+ -- end Pkg;
+
+ -- type T2 is new Pkg.T1 with null record;
+ -- procedure Prim (X : T2) is -- late overriding
+ -- begin
+ -- ...
+ -- ...
+ -- end;
+
+ function Make_DT (Typ : Entity_Id) return List_Id is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Is_Local_DT : constant Boolean :=
+ Ekind (Cunit_Entity (Get_Source_Unit (Typ)))
+ /= E_Package;
+ Max_Predef_Prims : constant Int :=
+ UI_To_Int
+ (Intval
+ (Expression
+ (Parent (RTE (RE_Default_Prim_Op_Count)))));
+
+ procedure Make_Secondary_DT
+ (Typ : Entity_Id;
+ Iface : Entity_Id;
+ AI_Tag : Entity_Id;
+ Iface_DT_Ptr : Entity_Id;
+ Result : List_Id);
+ -- Ada 2005 (AI-251): Expand the declarations for the Secondary Dispatch
+ -- Table of Typ associated with Iface (each abstract interface of Typ
+ -- has a secondary dispatch table). The arguments Typ, Ancestor_Typ
+ -- and Suffix_Index are used to generate an unique external name which
+ -- is added at the end of Acc_Disp_Tables; this external name will be
+ -- used later by the subprogram Exp_Ch3.Build_Init_Procedure.
+
+ -----------------------
+ -- Make_Secondary_DT --
+ -----------------------
+
+ procedure Make_Secondary_DT
+ (Typ : Entity_Id;
+ Iface : Entity_Id;
+ AI_Tag : Entity_Id;
+ Iface_DT_Ptr : Entity_Id;
+ Result : List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag);
+
+ Name_DT : constant Name_Id := New_Internal_Name ('T');
+ Iface_DT : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_DT);
+ Name_Predef_Prims : constant Name_Id := New_Internal_Name ('R');
+ Predef_Prims : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Name_Predef_Prims);
+ DT_Constr_List : List_Id;
+ DT_Aggr_List : List_Id;
+ Empty_DT : Boolean := False;
+ Nb_Predef_Prims : Nat := 0;
+ Nb_Prim : Nat;
+ New_Node : Node_Id;
+ OSD : Entity_Id;
+ OSD_Aggr_List : List_Id;
+ Pos : Nat;
+ Prim : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ Prim_Ops_Aggr_List : List_Id;
+
+ begin
+ -- Handle the case where the backend does not support statically
+ -- allocated dispatch tables.
+
+ if not Static_Dispatch_Tables
+ or else Is_Local_DT
+ then
+ Set_Ekind (Predef_Prims, E_Variable);
+ Set_Is_Statically_Allocated (Predef_Prims);
+
+ Set_Ekind (Iface_DT, E_Variable);
+ Set_Is_Statically_Allocated (Iface_DT);
+
+ -- Statically allocated dispatch tables and related entities are
+ -- constants.
+
+ else
+ Set_Ekind (Predef_Prims, E_Constant);
+ Set_Is_Statically_Allocated (Predef_Prims);
+ Set_Is_True_Constant (Predef_Prims);
+
+ Set_Ekind (Iface_DT, E_Constant);
+ Set_Is_Statically_Allocated (Iface_DT);
+ Set_Is_True_Constant (Iface_DT);
+ end if;
+
+ -- Generate code to create the storage for the Dispatch_Table object.
+ -- If the number of primitives of Typ is 0 we reserve a dummy single
+ -- entry for its DT because at run-time the pointer to this dummy
+ -- entry will be used as the tag.
+
+ Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag));
+
+ if Nb_Prim = 0 then
+ Empty_DT := True;
+ Nb_Prim := 1;
+ end if;
+
+ -- Generate:
+
+ -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
+ -- (predef-prim-op-thunk-1'address,
+ -- predef-prim-op-thunk-2'address,
+ -- ...
+ -- predef-prim-op-thunk-n'address);
+ -- for Predef_Prims'Alignment use Address'Alignment
+
+ -- Stage 1: Calculate the number of predefined primitives
+
+ if not Static_Dispatch_Tables then
+ Nb_Predef_Prims := Max_Predef_Prims;
+ else
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ if Is_Predefined_Dispatching_Operation (Prim)
+ and then not Is_Abstract_Subprogram (Prim)
+ then
+ Pos := UI_To_Int (DT_Position (Prim));
+
+ if Pos > Nb_Predef_Prims then
+ Nb_Predef_Prims := Pos;
+ end if;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end if;
+
+ -- Stage 2: Create the thunks associated with the predefined
+ -- primitives and save their entity to fill the aggregate.
+
+ declare
+ Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
+ Thunk_Id : Entity_Id;
+ Thunk_Code : Node_Id;
+
+ begin
+ Prim_Ops_Aggr_List := New_List;
+ Prim_Table := (others => Empty);
+
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ if Is_Predefined_Dispatching_Operation (Prim)
+ and then not Is_Abstract_Subprogram (Prim)
+ and then not Present (Prim_Table
+ (UI_To_Int (DT_Position (Prim))))
+ then
+ while Present (Alias (Prim)) loop
+ Prim := Alias (Prim);
+ end loop;
+
+ Expand_Interface_Thunk
+ (N => Prim,
+ Thunk_Alias => Prim,
+ Thunk_Id => Thunk_Id,
+ Thunk_Code => Thunk_Code);
+
+ if Present (Thunk_Id) then
+ Append_To (Result, Thunk_Code);
+ Prim_Table (UI_To_Int (DT_Position (Prim))) := Thunk_Id;
+ end if;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ for J in Prim_Table'Range loop
+ if Present (Prim_Table (J)) then
+ New_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Prim_Table (J), Loc),
+ Attribute_Name => Name_Address);
+ else
+ New_Node :=
+ New_Reference_To (RTE (RE_Null_Address), Loc);
+ end if;
+
+ Append_To (Prim_Ops_Aggr_List, New_Node);
+ end loop;
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Predef_Prims,
+ Constant_Present => Static_Dispatch_Tables,
+ Aliased_Present => True,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Address_Array), Loc),
+ Expression => Make_Aggregate (Loc,
+ Expressions => Prim_Ops_Aggr_List)));
+
+ Append_To (Result,
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Reference_To (Predef_Prims, Loc),
+ Chars => Name_Alignment,
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (RTE (RE_Integer_Address), Loc),
+ Attribute_Name => Name_Alignment)));
+ end;
+
+ -- Generate
+
+ -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
+ -- (OSD_Table => (1 => <value>,
+ -- ...
+ -- N => <value>));
+
+ -- Iface_DT : Dispatch_Table (Nb_Prims) :=
+ -- ([ Signature => <sig-value> ],
+ -- Tag_Kind => <tag_kind-value>,
+ -- Predef_Prims => Predef_Prims'Address,
+ -- Offset_To_Top => 0,
+ -- OSD => OSD'Address,
+ -- Prims_Ptr => (prim-op-1'address,
+ -- prim-op-2'address,
+ -- ...
+ -- prim-op-n'address));
+
+ -- Stage 3: Initialize the discriminant and the record components
+
+ DT_Constr_List := New_List;
+ DT_Aggr_List := New_List;
+
+ -- Nb_Prim. If the tagged type has no primitives we add a dummy
+ -- slot whose address will be the tag of this type.
+
+ if Nb_Prim = 0 then
+ New_Node := Make_Integer_Literal (Loc, 1);
+ else
+ New_Node := Make_Integer_Literal (Loc, Nb_Prim);
+ end if;
+
+ Append_To (DT_Constr_List, New_Node);
+ Append_To (DT_Aggr_List, New_Copy (New_Node));
+
+ -- Signature
+
+ if RTE_Record_Component_Available (RE_Signature) then
+ Append_To (DT_Aggr_List,
+ New_Reference_To (RTE (RE_Secondary_DT), Loc));
+ end if;
+
+ -- Tag_Kind
+
+ if RTE_Record_Component_Available (RE_Tag_Kind) then
+ Append_To (DT_Aggr_List, Tagged_Kind (Typ));
+ end if;
+
+ -- Predef_Prims
+
+ Append_To (DT_Aggr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Predef_Prims, Loc),
+ Attribute_Name => Name_Address));
+
+ -- Note: The correct value of Offset_To_Top will be set by the init
+ -- subprogram
+
+ Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
+
+ -- Generate the Object Specific Data table required to dispatch calls
+ -- through synchronized interfaces.
+
+ if Empty_DT
+ or else Is_Abstract_Type (Typ)
+ or else Is_Controlled (Typ)
+ or else Restriction_Active (No_Dispatching_Calls)
+ or else not Is_Limited_Type (Typ)
+ or else not Has_Abstract_Interfaces (Typ)
+ then
+ -- No OSD table required
+
+ Append_To (DT_Aggr_List,
+ New_Reference_To (RTE (RE_Null_Address), Loc));
+
+ else
+ OSD_Aggr_List := New_List;
+
+ declare
+ Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
+ Prim : Entity_Id;
+ Prim_Alias : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ E : Entity_Id;
+ Count : Nat := 0;
+ Pos : Nat;
+
+ begin
+ Prim_Table := (others => Empty);
+ Prim_Alias := Empty;
+
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ if Present (Abstract_Interface_Alias (Prim))
+ and then Find_Dispatching_Type
+ (Abstract_Interface_Alias (Prim)) = Iface
+ then
+ Prim_Alias := Abstract_Interface_Alias (Prim);
+
+ E := Prim;
+ while Present (Alias (E)) loop
+ E := Alias (E);
+ end loop;
+
+ Pos := UI_To_Int (DT_Position (Prim_Alias));
+
+ if Present (Prim_Table (Pos)) then
+ pragma Assert (Prim_Table (Pos) = E);
+ null;
+
+ else
+ Prim_Table (Pos) := E;
+
+ Append_To (OSD_Aggr_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Integer_Literal (Loc,
+ DT_Position (Prim_Alias))),
+ Expression =>
+ Make_Integer_Literal (Loc,
+ DT_Position (Alias (Prim)))));
+
+ Count := Count + 1;
+ end if;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ pragma Assert (Count = Nb_Prim);
+ end;
+
+ OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => OSD,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Object_Specific_Data), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Integer_Literal (Loc, Nb_Prim)))),
+ Expression => Make_Aggregate (Loc,
+ Component_Associations => New_List (
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_OSD_Num_Prims), Loc)),
+ Expression =>
+ Make_Integer_Literal (Loc, Nb_Prim)),
+
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_OSD_Table), Loc)),
+ Expression => Make_Aggregate (Loc,
+ Component_Associations => OSD_Aggr_List))))));
+
+ -- In secondary dispatch tables the Typeinfo component contains
+ -- the address of the Object Specific Data (see a-tags.ads)
+
+ Append_To (DT_Aggr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (OSD, Loc),
+ Attribute_Name => Name_Address));
+ end if;
+
+ -- Initialize the table of primitive operations
+
+ Prim_Ops_Aggr_List := New_List;
+
+ if Empty_DT then
+ Append_To (Prim_Ops_Aggr_List,
+ New_Reference_To (RTE (RE_Null_Address), Loc));
+
+ elsif Is_Abstract_Type (Typ)
+ or else not Static_Dispatch_Tables
+ then
+ for J in 1 .. Nb_Prim loop
+ Append_To (Prim_Ops_Aggr_List,
+ New_Reference_To (RTE (RE_Null_Address), Loc));
+ end loop;
+
+ else
+ declare
+ Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
+ Pos : Nat;
+ Thunk_Code : Node_Id;
+ Thunk_Id : Entity_Id;
+
+ begin
+ Prim_Table := (others => Empty);
+
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ if not Is_Predefined_Dispatching_Operation (Prim)
+ and then Present (Abstract_Interface_Alias (Prim))
+ and then not Is_Abstract_Subprogram (Alias (Prim))
+ and then not Is_Imported (Alias (Prim))
+ and then Find_Dispatching_Type
+ (Abstract_Interface_Alias (Prim)) = Iface
+
+ -- Generate the code of the thunk only if the abstract
+ -- interface type is not an immediate ancestor of
+ -- Tagged_Type; otherwise the DT associated with the
+ -- interface is the primary DT.
+
+ and then not Is_Parent (Iface, Typ)
+ then
+ Expand_Interface_Thunk
+ (N => Prim,
+ Thunk_Alias => Alias (Prim),
+ Thunk_Id => Thunk_Id,
+ Thunk_Code => Thunk_Code);
+
+ if Present (Thunk_Id) then
+ Pos :=
+ UI_To_Int
+ (DT_Position (Abstract_Interface_Alias (Prim)));
+
+ Prim_Table (Pos) := Thunk_Id;
+ Append_To (Result, Thunk_Code);
+ end if;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ for J in Prim_Table'Range loop
+ if Present (Prim_Table (J)) then
+ New_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Prim_Table (J), Loc),
+ Attribute_Name => Name_Address);
+ else
+ New_Node :=
+ New_Reference_To (RTE (RE_Null_Address), Loc);
+ end if;
+
+ Append_To (Prim_Ops_Aggr_List, New_Node);
+ end loop;
+ end;
+ end if;
+
+ Append_To (DT_Aggr_List,
+ Make_Aggregate (Loc,
+ Expressions => Prim_Ops_Aggr_List));
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Iface_DT,
+ Aliased_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To
+ (RTE (RE_Dispatch_Table_Wrapper), Loc),
+ Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => DT_Constr_List)),
+
+ Expression => Make_Aggregate (Loc,
+ Expressions => DT_Aggr_List)));
+
+ -- Generate code to create the pointer to the dispatch table
+
+ -- Iface_DT_Ptr : Tag := Tag!(DT'Address);
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Iface_DT_Ptr,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Interface_Tag), Loc),
+ Expression =>
+ Unchecked_Convert_To (Generalized_Tag,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (Iface_DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+ Attribute_Name => Name_Address))));
+
+ end Make_Secondary_DT;
+
+ -- Local variables
+
+ -- Seems a huge list, shouldn't some of these be commented???
+ -- Seems like we are counting too much on guessing from names here???
+
+ Elab_Code : constant List_Id := New_List;
+ Generalized_Tag : constant Entity_Id := RTE (RE_Tag);
+ Result : constant List_Id := New_List;
+ Tname : constant Name_Id := Chars (Typ);
+ Name_DT : constant Name_Id := New_External_Name (Tname, 'T');
+ Name_Exname : constant Name_Id := New_External_Name (Tname, 'E');
+ Name_Predef_Prims : constant Name_Id := New_External_Name (Tname, 'R');
+ Name_SSD : constant Name_Id := New_External_Name (Tname, 'S');
+ Name_TSD : constant Name_Id := New_External_Name (Tname, 'B');
+ DT : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_DT);
+ Exname : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_Exname);
+ Predef_Prims : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_Predef_Prims);
+ SSD : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_SSD);
+ TSD : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_TSD);
+ AI : Elmt_Id;
+ AI_Tag_Comp : Elmt_Id;
+ AI_Ptr_Elmt : Elmt_Id;
+ DT_Constr_List : List_Id;
+ DT_Aggr_List : List_Id;
+ DT_Ptr : Entity_Id;
+ Has_Dispatch_Table : Boolean := True;
+ ITable : Node_Id;
+ I_Depth : Nat := 0;
+ Iface_Table_Node : Node_Id;
+ Name_ITable : Name_Id;
+ Name_No_Reg : Name_Id;
+ Nb_Predef_Prims : Nat := 0;
+ Nb_Prim : Nat := 0;
+ New_Node : Node_Id;
+ No_Reg : Node_Id;
+ Null_Parent_Tag : Boolean := False;
+ Num_Ifaces : Nat := 0;
+ Old_Tag1 : Node_Id;
+ Old_Tag2 : Node_Id;
+ Prim : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ Prim_Ops_Aggr_List : List_Id;
+ Transportable : Entity_Id;
+ RC_Offset_Node : Node_Id;
+ Suffix_Index : Int;
+ Typ_Comps : Elist_Id;
+ Typ_Ifaces : Elist_Id;
+ TSD_Aggr_List : List_Id;
+ TSD_Tags_List : List_Id;
+ TSD_Ifaces_List : List_Id;
+
+ -- Start of processing for Make_DT
+
+ begin
+ -- Fill the contents of Access_Disp_Table
+
+ -- 1) Generate the primary and secondary tag entities
+
+ declare
+ DT_Ptr : Node_Id;
+ Name_DT_Ptr : Name_Id;
+ Typ_Name : Name_Id;
+ Iface_DT_Ptr : Node_Id;
+ Suffix_Index : Int;
+ AI_Tag_Comp : Elmt_Id;
+
+ begin
+ -- Collect the components associated with secondary dispatch tables
+
+ if Has_Abstract_Interfaces (Typ) then
+ Collect_Interface_Components (Typ, Typ_Comps);
+ end if;
+
+ -- Generate the primary tag entity
+
+ Name_DT_Ptr := New_External_Name (Tname, 'P');
+ DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr);
+ Set_Ekind (DT_Ptr, E_Constant);
+ Set_Is_Statically_Allocated (DT_Ptr);
+ Set_Is_True_Constant (DT_Ptr);
+
+ pragma Assert (No (Access_Disp_Table (Typ)));
+ Set_Access_Disp_Table (Typ, New_Elmt_List);
+ Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
+
+ -- Generate the secondary tag entities
+
+ if Has_Abstract_Interfaces (Typ) then
+ Suffix_Index := 0;
+
+ -- For each interface type we build an unique external name
+ -- associated with its corresponding secondary dispatch table.
+ -- This external name will be used to declare an object that
+ -- references this secondary dispatch table, value that will be
+ -- used for the elaboration of Typ's objects and also for the
+ -- elaboration of objects of derivations of Typ that do not
+ -- override the primitive operation of this interface type.
+
+ AI_Tag_Comp := First_Elmt (Typ_Comps);
+ while Present (AI_Tag_Comp) loop
+ Get_Secondary_DT_External_Name
+ (Typ, Related_Interface (Node (AI_Tag_Comp)), Suffix_Index);
+
+ Typ_Name := Name_Find;
+ Name_DT_Ptr := New_External_Name (Typ_Name, "P");
+ Iface_DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr);
+
+ Set_Ekind (Iface_DT_Ptr, E_Constant);
+ Set_Is_Statically_Allocated (Iface_DT_Ptr);
+ Set_Is_True_Constant (Iface_DT_Ptr);
+ Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+
+ Next_Elmt (AI_Tag_Comp);
+ end loop;
+ end if;
+ end;
+
+ -- 2) At the end of Access_Disp_Table we add the entity of an access
+ -- type declaration. It is used by Build_Get_Prim_Op_Address to
+ -- expand dispatching calls through the primary dispatch table.
+
+ -- Generate:
+ -- type Typ_DT is array (1 .. Nb_Prims) of Address;
+ -- type Typ_DT_Acc is access Typ_DT;
+
+ declare
+ Name_DT_Prims : constant Name_Id :=
+ New_External_Name (Tname, 'G');
+ Name_DT_Prims_Acc : constant Name_Id :=
+ New_External_Name (Tname, 'H');
+ DT_Prims : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_DT_Prims);
+ DT_Prims_Acc : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Name_DT_Prims_Acc);
+ begin
+ Append_To (Result,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => DT_Prims,
+ Type_Definition =>
+ Make_Constrained_Array_Definition (Loc,
+ Discrete_Subtype_Definitions => New_List (
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound => Make_Integer_Literal (Loc,
+ DT_Entry_Count
+ (First_Tag_Component (Typ))))),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Subtype_Indication =>
+ New_Reference_To (RTE (RE_Address), Loc)))));
+
+ Append_To (Result,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => DT_Prims_Acc,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (DT_Prims, Loc))));
+
+ Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
+ end;
+
+ if Is_CPP_Class (Typ) then
+ return Result;
+ end if;
+
+ if No_Run_Time_Mode or else not RTE_Available (RE_Tag) then
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT_Ptr,
+ Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
+ Constant_Present => True,
+ Expression =>
+ Unchecked_Convert_To (Generalized_Tag,
+ New_Reference_To (RTE (RE_Null_Address), Loc))));
+
+ Analyze_List (Result, Suppress => All_Checks);
+ Error_Msg_CRT ("tagged types", Typ);
+ return Result;
+ end if;
+
+ if not Static_Dispatch_Tables
+ or else Is_Local_DT
+ then
+ Set_Ekind (DT, E_Variable);
+ Set_Is_Statically_Allocated (DT);
+ else
+ Set_Ekind (DT, E_Constant);
+ Set_Is_Statically_Allocated (DT);
+ Set_Is_True_Constant (DT);
+ end if;
+
+ pragma Assert (Present (Access_Disp_Table (Typ)));
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+
+ -- Ada 2005 (AI-251): Build the secondary dispatch tables
+
+ if Has_Abstract_Interfaces (Typ) then
+ Suffix_Index := 0;
+ AI_Ptr_Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+
+ AI_Tag_Comp := First_Elmt (Typ_Comps);
+ while Present (AI_Tag_Comp) loop
+ Make_Secondary_DT
+ (Typ => Typ,
+ Iface => Base_Type
+ (Related_Interface (Node (AI_Tag_Comp))),
+ AI_Tag => Node (AI_Tag_Comp),
+ Iface_DT_Ptr => Node (AI_Ptr_Elmt),
+ Result => Result);
+
+ Suffix_Index := Suffix_Index + 1;
+ Next_Elmt (AI_Ptr_Elmt);
+ Next_Elmt (AI_Tag_Comp);
+ end loop;
+ end if;
+
+ -- Evaluate if we generate the dispatch table
+
+ Has_Dispatch_Table :=
+ not Is_Interface (Typ)
+ and then not Restriction_Active (No_Dispatching_Calls);
+
+ -- Calculate the number of primitives of the dispatch table and the
+ -- size of the Type_Specific_Data record.
+
+ if Has_Dispatch_Table then
+ Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
+ end if;
+
+ if not Static_Dispatch_Tables then
+ Set_Ekind (Predef_Prims, E_Variable);
+ Set_Is_Statically_Allocated (Predef_Prims);
+ else
+ Set_Ekind (Predef_Prims, E_Constant);
+ Set_Is_Statically_Allocated (Predef_Prims);
+ Set_Is_True_Constant (Predef_Prims);
+ end if;
+
+ Set_Ekind (SSD, E_Constant);
+ Set_Is_Statically_Allocated (SSD);
+ Set_Is_True_Constant (SSD);
+
+ Set_Ekind (TSD, E_Constant);
+ Set_Is_Statically_Allocated (TSD);
+ Set_Is_True_Constant (TSD);
+
+ Set_Ekind (Exname, E_Constant);
+ Set_Is_Statically_Allocated (Exname);
+ Set_Is_True_Constant (Exname);
+
+ -- Generate code to define the boolean that controls registration, in
+ -- order to avoid multiple registrations for tagged types defined in
+ -- multiple-called scopes.
+
+ if not Is_Interface (Typ) then
+ Name_No_Reg := New_External_Name (Tname, 'F');
+ No_Reg := Make_Defining_Identifier (Loc, Name_No_Reg);
+
+ Set_Ekind (No_Reg, E_Variable);
+ Set_Is_Statically_Allocated (No_Reg);
+
+ 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)));
+ end if;
+
+ -- In case of locally defined tagged type we declare the object
+ -- contanining the dispatch table by means of a variable. Its
+ -- initialization is done later by means of an assignment. This is
+ -- required to generate its External_Tag.
+
+ if Is_Local_DT then
+
+ -- Generate:
+ -- DT : No_Dispatch_Table_Wrapper;
+ -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
+
+ if not Has_Dispatch_Table then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT,
+ Aliased_Present => True,
+ Constant_Present => False,
+ Object_Definition =>
+ New_Reference_To
+ (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT_Ptr,
+ Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
+ Constant_Present => True,
+ Expression =>
+ Unchecked_Convert_To (Generalized_Tag,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
+ Attribute_Name => Name_Address))));
+
+ -- Generate:
+ -- DT : Dispatch_Table_Wrapper (Nb_Prim);
+ -- for DT'Alignment use Address'Alignment;
+ -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
+
+ else
+ -- If the tagged type has no primitives we add a dummy slot
+ -- whose address will be the tag of this type.
+
+ if Nb_Prim = 0 then
+ DT_Constr_List :=
+ New_List (Make_Integer_Literal (Loc, 1));
+ else
+ DT_Constr_List :=
+ New_List (Make_Integer_Literal (Loc, Nb_Prim));
+ end if;
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT,
+ Aliased_Present => True,
+ Constant_Present => False,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc),
+ Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => DT_Constr_List))));
+
+ 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)));
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT_Ptr,
+ Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
+ Constant_Present => True,
+ Expression =>
+ Unchecked_Convert_To (Generalized_Tag,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+ Attribute_Name => Name_Address))));
+ end if;
+ end if;
+
+ -- Generate: Exname : constant String := full_qualified_name (typ);
+ -- The type itself may be an anonymous parent type, so use the first
+ -- subtype to have a user-recognizable name.
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Exname,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (Standard_String, Loc),
+ Expression =>
+ Make_String_Literal (Loc,
+ Full_Qualified_Name (First_Subtype (Typ)))));
+
+ -- Generate code to create the storage for the type specific data object
+ -- with enough space to store the tags of the ancestors plus the tags
+ -- of all the implemented interfaces (as described in a-tags.adb).
+
+ -- TSD : Type_Specific_Data (I_Depth) :=
+ -- (Idepth => I_Depth,
+ -- Access_Level => Type_Access_Level (Typ),
+ -- Expanded_Name => Cstring_Ptr!(Exname'Address))
+ -- External_Tag => Cstring_Ptr!(Exname'Address))
+ -- HT_Link => null,
+ -- Transportable => <<boolean-value>>,
+ -- RC_Offset => <<integer-value>>,
+ -- [ Interfaces_Table => <<access-value>> ]
+ -- [ SSD => SSD_Table'Address ]
+ -- Tags_Table => (0 => null,
+ -- 1 => Parent'Tag
+ -- ...);
+ -- for TSD'Alignment use Address'Alignment
+
+ TSD_Aggr_List := New_List;
+
+ -- Idepth: 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
+ Current_Typ : Entity_Id;
+ Parent_Typ : Entity_Id;
+
+ begin
+ I_Depth := 0;
+ Current_Typ := Typ;
+ loop
+ Parent_Typ := Etype (Current_Typ);
+
+ if Is_Private_Type (Parent_Typ) then
+ Parent_Typ := Full_View (Base_Type (Parent_Typ));
+ end if;
+
+ exit when Parent_Typ = Current_Typ;
+
+ I_Depth := I_Depth + 1;
+ Current_Typ := Parent_Typ;
+ end loop;
+ end;
+
+ Append_To (TSD_Aggr_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of (RTE_Record_Component (RE_Idepth), Loc)),
+ Expression =>
+ Make_Integer_Literal (Loc, I_Depth)));
+
+ -- Access_Level
+
+ Append_To (TSD_Aggr_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of (RTE_Record_Component (RE_Access_Level), Loc)),
+ Expression =>
+ Make_Integer_Literal (Loc, Type_Access_Level (Typ))));
+
+ -- Expanded_Name
+
+ Append_To (TSD_Aggr_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of (RTE_Record_Component (RE_Expanded_Name), Loc)),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Exname, Loc),
+ Attribute_Name => Name_Address))));
+
+ -- External_Tag of a local tagged type
+
+ -- Exname : constant String :=
+ -- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
+
+ -- The reason we generate this strange name is that we do not want to
+ -- enter local tagged types in the global hash table used to compute
+ -- the Internal_Tag attribute for two reasons:
+
+ -- 1. It is hard to avoid a tasking race condition for entering the
+ -- entry into the hash table.
+
+ -- 2. It would cause a storage leak, unless we rig up considerable
+ -- mechanism to remove the entry from the hash table on exit.
+
+ -- So what we do is to generate the above external tag name, where the
+ -- hex address is the address of the local dispatch table (i.e. exactly
+ -- the value we want if Internal_Tag is computed from this string).
+
+ -- Of course this value will only be valid if the tagged type is still
+ -- in scope, but it clearly must be erroneous to compute the internal
+ -- tag of a tagged type that is out of scope!
+
+ if Is_Local_DT then
+ declare
+ Name_Exname : constant Name_Id := New_External_Name (Tname, 'L');
+ Name_Str1 : constant Name_Id := New_Internal_Name ('I');
+ Name_Str2 : constant Name_Id := New_Internal_Name ('I');
+ Name_Str3 : constant Name_Id := New_Internal_Name ('I');
+ Exname : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_Exname);
+ Str1 : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_Str1);
+ Str2 : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_Str2);
+ Str3 : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_Str3);
+ Full_Name : constant String_Id :=
+ Full_Qualified_Name (First_Subtype (Typ));
+ Str1_Id : String_Id;
+ Str2_Id : String_Id;
+ Str3_Id : String_Id;
+
+ begin
+ -- Generate:
+ -- Str1 : constant String := "Internal tag at 16#";
+
+ Set_Ekind (Str1, E_Constant);
+ Set_Is_Statically_Allocated (Str1);
+ Set_Is_True_Constant (Str1);
+
+ Start_String;
+ Store_String_Chars ("Internal tag at 16#");
+ Str1_Id := End_String;
+
+ -- Generate:
+ -- Str2 : constant String := "#: ";
+
+ Set_Ekind (Str2, E_Constant);
+ Set_Is_Statically_Allocated (Str2);
+ Set_Is_True_Constant (Str2);
+
+ Start_String;
+ Store_String_Chars ("#: ");
+ Str2_Id := End_String;
+
+ -- Generate:
+ -- Str3 : constant String := <full-name-of-typ>;
+
+ Set_Ekind (Str3, E_Constant);
+ Set_Is_Statically_Allocated (Str3);
+ Set_Is_True_Constant (Str3);
+
+ Start_String;
+ Store_String_Chars (Full_Name);
+ Str3_Id := End_String;
+
+ -- Generate:
+ -- Exname : constant String :=
+ -- Str1 & Address_Image (Tag) & Str2 & Str3;
+
+ if RTE_Available (RE_Address_Image) then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Exname,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To
+ (Standard_String, Loc),
+ Expression =>
+ Make_Op_Concat (Loc,
+ Left_Opnd =>
+ Make_String_Literal (Loc, Str1_Id),
+ Right_Opnd =>
+ Make_Op_Concat (Loc,
+ Left_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To
+ (RTE (RE_Address_Image), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Address),
+ New_Reference_To (DT_Ptr, Loc)))),
+ Right_Opnd =>
+ Make_Op_Concat (Loc,
+ Left_Opnd =>
+ Make_String_Literal (Loc, Str2_Id),
+ Right_Opnd =>
+ Make_String_Literal (Loc, Str3_Id))))));
+ else
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Exname,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To
+ (Standard_String, Loc),
+ Expression =>
+ Make_Op_Concat (Loc,
+ Left_Opnd =>
+ Make_String_Literal (Loc, Str1_Id),
+ Right_Opnd =>
+ Make_Op_Concat (Loc,
+ Left_Opnd =>
+ Make_String_Literal (Loc, Str2_Id),
+ Right_Opnd =>
+ Make_String_Literal (Loc, Str3_Id)))));
+ end if;
+
+ New_Node :=
+ Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Exname, Loc),
+ Attribute_Name => Name_Address));
+ end;
+
+ -- External tag of a library-level tagged type: Check for a definition
+ -- of External_Tag. The clause is considered only if it applies to this
+ -- specific tagged type, as opposed to one of its ancestors.
+
+ else
+ declare
+ Def : constant Node_Id := Get_Attribute_Definition_Clause (Typ,
+ Attribute_External_Tag);
+ Old_Val : String_Id;
+ New_Val : String_Id;
+ E : Entity_Id;
+
+ begin
+ if not Present (Def)
+ or else Entity (Name (Def)) /= Typ
+ then
+ New_Node :=
+ Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Exname, Loc),
+ Attribute_Name => Name_Address));
+ else
+ Old_Val := Strval (Expr_Value_S (Expression (Def)));
+
+ -- For the rep clause "for x'external_tag use y" generate:
+
+ -- xV : constant string := y;
+ -- Set_External_Tag (x'tag, xV'Address);
+ -- Register_Tag (x'tag);
+
+ -- Create a new nul terminated string if it is not already
+
+ if String_Length (Old_Val) > 0
+ and then
+ Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
+ then
+ New_Val := Old_Val;
+ else
+ Start_String (Old_Val);
+ Store_String_Char (Get_Char_Code (ASCII.NUL));
+ New_Val := End_String;
+ end if;
+
+ E := Make_Defining_Identifier (Loc,
+ New_External_Name (Chars (Typ), 'A'));
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => E,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (Standard_String, Loc),
+ Expression =>
+ Make_String_Literal (Loc, New_Val)));
+
+ New_Node :=
+ Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (E, Loc),
+ Attribute_Name => Name_Address));
+ end if;
+ end;
+ end if;
+
+ Append_To (TSD_Aggr_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_External_Tag), Loc)),
+ Expression => New_Node));
+
+ -- HT_Link
+
+ Append_To (TSD_Aggr_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_HT_Link), Loc)),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (RTE (RE_Null_Address), Loc))));
+
+ -- Transportable: Set for types that can be used in remote calls
+ -- with respect to E.4(18) legality rules.
+
+ Transportable :=
+ 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 (TSD_Aggr_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Transportable), Loc)),
+ Expression => New_Occurrence_Of (Transportable, Loc)));
+
+ -- RC_Offset: These are the valid values and their meaning:
+
+ -- >0: For simple types with controlled components is
+ -- type._record_controller'position
+
+ -- 0: For types with no controlled components
+
+ -- -1: For complex types with controlled components where the position
+ -- of the record controller is not statically computable but there
+ -- are controlled components at this level. The _Controller field
+ -- is available right after the _parent.
+
+ -- -2: There are no controlled components at this level. We need to
+ -- get the position from the parent.
+
+ if not Has_Controlled_Component (Typ) then
+ RC_Offset_Node := Make_Integer_Literal (Loc, 0);
+
+ elsif Etype (Typ) /= Typ
+ and then Has_Discriminants (Etype (Typ))
+ then
+ if Has_New_Controlled_Component (Typ) then
+ RC_Offset_Node := Make_Integer_Literal (Loc, -1);
+ else
+ RC_Offset_Node := Make_Integer_Literal (Loc, -2);
+ end if;
+ else
+ RC_Offset_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Selector_Name =>
+ New_Reference_To (Controller_Component (Typ), Loc)),
+ Attribute_Name => Name_Position);
+
+ -- This is not proper Ada code to use the attribute 'Position
+ -- on something else than an object but this is supported by
+ -- the back end (see comment on the Bit_Component attribute in
+ -- sem_attr). So we avoid semantic checking here.
+
+ -- Is this documented in sinfo.ads??? it should be!
+
+ Set_Analyzed (RC_Offset_Node);
+ Set_Etype (Prefix (RC_Offset_Node), RTE (RE_Record_Controller));
+ Set_Etype (Prefix (Prefix (RC_Offset_Node)), Typ);
+ Set_Etype (Selector_Name (Prefix (RC_Offset_Node)),
+ RTE (RE_Record_Controller));
+ Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset));
+ end if;
+
+ Append_To (TSD_Aggr_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of (RTE_Record_Component (RE_RC_Offset), Loc)),
+ Expression => RC_Offset_Node));
+
+ -- Interfaces_Table (required for AI-405)
+
+ if RTE_Record_Component_Available (RE_Interfaces_Table) then
+
+ -- Count the number of interface types implemented by Typ
+
+ Collect_Abstract_Interfaces (Typ, Typ_Ifaces);
+
+ AI := First_Elmt (Typ_Ifaces);
+ while Present (AI) loop
+ Num_Ifaces := Num_Ifaces + 1;
+ Next_Elmt (AI);
+ end loop;
+
+ if Num_Ifaces = 0 then
+ Iface_Table_Node := Make_Null (Loc);
+
+ -- Generate the Interface_Table object
+
+ else
+ TSD_Ifaces_List := New_List;
+
+ declare
+ Pos : Nat := 1;
+ Aggr_List : List_Id;
+
+ begin
+ AI := First_Elmt (Typ_Ifaces);
+ while Present (AI) loop
+ Aggr_List := New_List (
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Iface_Tag), Loc)),
+ Expression =>
+ Unchecked_Convert_To (Generalized_Tag,
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Node (AI)))),
+ Loc))),
+
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Static_Offset_To_Top),
+ Loc)),
+ Expression =>
+ New_Reference_To (Standard_True, Loc)),
+
+ Make_Component_Association (Loc,
+ Choices => New_List (Make_Others_Choice (Loc)),
+ Expression => Empty,
+ Box_Present => True));
+
+ Append_To (TSD_Ifaces_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Integer_Literal (Loc, Pos)),
+ Expression => Make_Aggregate (Loc,
+ Component_Associations => Aggr_List)));
+
+ Pos := Pos + 1;
+ Next_Elmt (AI);
+ end loop;
+ end;
+
+ Name_ITable := New_External_Name (Tname, 'I');
+ ITable := Make_Defining_Identifier (Loc, Name_ITable);
+
+ Set_Ekind (ITable, E_Constant);
+ Set_Is_Statically_Allocated (ITable);
+ Set_Is_True_Constant (ITable);
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => ITable,
+ Aliased_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Interface_Data), Loc),
+ Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Integer_Literal (Loc, Num_Ifaces)))),
+
+ Expression => Make_Aggregate (Loc,
+ Component_Associations => New_List (
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Nb_Ifaces), Loc)),
+ Expression =>
+ Make_Integer_Literal (Loc, Num_Ifaces)),
+
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Ifaces_Table), Loc)),
+ Expression => Make_Aggregate (Loc,
+ Component_Associations => TSD_Ifaces_List))))));
+
+ Iface_Table_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (ITable, Loc),
+ Attribute_Name => Name_Unchecked_Access);
+ end if;
+
+ Append_To (TSD_Aggr_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Interfaces_Table), Loc)),
+ Expression => Iface_Table_Node));
+ end if;
+
+ -- Generate the Select Specific Data table for synchronized types that
+ -- implement synchronized interfaces. The size of the table is
+ -- constrained by the number of non-predefined primitive operations.
+
+ if RTE_Record_Component_Available (RE_SSD) then
+ if Ada_Version >= Ada_05
+ and then Has_Dispatch_Table
+ and then Is_Concurrent_Record_Type (Typ)
+ and then Has_Abstract_Interfaces (Typ)
+ and then Nb_Prim > 0
+ and then not Is_Abstract_Type (Typ)
+ and then not Is_Controlled (Typ)
+ and then not Restriction_Active (No_Dispatching_Calls)
+ then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => SSD,
+ Aliased_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To (
+ RTE (RE_Select_Specific_Data), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Integer_Literal (Loc, Nb_Prim))))));
+
+ -- This table is initialized by Make_Select_Specific_Data_Table,
+ -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
+
+ Append_To (TSD_Aggr_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_SSD), Loc)),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (SSD, Loc),
+ Attribute_Name => Name_Unchecked_Access)));
+ else
+ Append_To (TSD_Aggr_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_SSD), Loc)),
+ Expression => Make_Null (Loc)));
+ end if;
+ end if;
+
+ -- Initialize the table of ancestor tags. In case of interface types
+ -- this table is not needed.
+
+ if Is_Interface (Typ) then
+ Append_To (TSD_Aggr_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (Make_Others_Choice (Loc)),
+ Expression => Empty,
+ Box_Present => True));
+ else
+ declare
+ Current_Typ : Entity_Id;
+ Parent_Typ : Entity_Id;
+ Pos : Nat;
+
+ begin
+ TSD_Tags_List := New_List;
+
+ -- Fill position 0 with null because we still have not generated
+ -- the tag of Typ.
+
+ Append_To (TSD_Tags_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Integer_Literal (Loc, 0)),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (RTE (RE_Null_Address), Loc))));
+
+ -- Fill the rest of the table with the tags of the ancestors
+
+ Pos := 1;
+ Current_Typ := Typ;
+
+ loop
+ Parent_Typ := Etype (Current_Typ);
+
+ if Is_Private_Type (Parent_Typ) then
+ Parent_Typ := Full_View (Base_Type (Parent_Typ));
+ end if;
+
+ exit when Parent_Typ = Current_Typ;
+
+ if Is_CPP_Class (Parent_Typ) then
+
+ -- The tags defined in the C++ side will be inherited when
+ -- the object is constructed.
+ -- (see Exp_Ch3.Build_Init_Procedure)
+
+ Append_To (TSD_Tags_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Integer_Literal (Loc, Pos)),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (RTE (RE_Null_Address), Loc))));
+ else
+ Append_To (TSD_Tags_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Integer_Literal (Loc, Pos)),
+ Expression =>
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Parent_Typ))),
+ Loc)));
+ end if;
+
+ Pos := Pos + 1;
+ Current_Typ := Parent_Typ;
+ end loop;
+
+ pragma Assert (Pos = I_Depth + 1);
+ end;
+
+ Append_To (TSD_Aggr_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Tags_Table), Loc)),
+ Expression => Make_Aggregate (Loc,
+ Component_Associations => TSD_Tags_List)));
+ end if;
+
+ -- Build the TSD object
+
+ 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_Type_Specific_Data), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Integer_Literal (Loc, I_Depth)))),
+
+ Expression => Make_Aggregate (Loc,
+ Component_Associations => TSD_Aggr_List)));
+
+ 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 the dummy Dispatch_Table object associated with tagged
+ -- types that have no dispatch table.
+
+ -- DT : No_Dispatch_Table :=
+ -- (NDT_TSD => TSD'Address;
+ -- NDT_Prims_Ptr => 0);
+
+ if not Has_Dispatch_Table then
+ DT_Constr_List := New_List;
+ DT_Aggr_List := New_List;
+
+ -- Typeinfo
+
+ New_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (TSD, Loc),
+ Attribute_Name => Name_Address);
+
+ Append_To (DT_Constr_List, New_Node);
+ Append_To (DT_Aggr_List, New_Copy (New_Node));
+ Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
+
+ -- In case of locally defined tagged types we have already declared
+ -- and uninitialized object for the dispatch table, which is now
+ -- initialized by means of an assignment.
+
+ if Is_Local_DT then
+ Append_To (Result,
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (DT, Loc),
+ Expression => Make_Aggregate (Loc,
+ Expressions => DT_Aggr_List)));
+
+ -- In case of library level tagged types we declare now the constant
+ -- object containing the dispatch table.
+
+ else
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT,
+ Aliased_Present => True,
+ Constant_Present => Static_Dispatch_Tables,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc),
+ Expression => Make_Aggregate (Loc,
+ Expressions => DT_Aggr_List)));
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT_Ptr,
+ Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
+ Constant_Present => True,
+ Expression =>
+ Unchecked_Convert_To (Generalized_Tag,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
+ Attribute_Name => Name_Address))));
+ end if;
+
+ -- Common case: Typ has a dispatch table
+
+ -- Generate:
+
+ -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
+ -- (predef-prim-op-1'address,
+ -- predef-prim-op-2'address,
+ -- ...
+ -- predef-prim-op-n'address);
+ -- for Predef_Prims'Alignment use Address'Alignment
+
+ -- DT : Dispatch_Table (Nb_Prims) :=
+ -- (Signature => <sig-value>,
+ -- Tag_Kind => <tag_kind-value>,
+ -- Predef_Prims => Predef_Prims'First'Address,
+ -- Offset_To_Top => 0,
+ -- TSD => TSD'Address;
+ -- Prims_Ptr => (prim-op-1'address,
+ -- prim-op-2'address,
+ -- ...
+ -- prim-op-n'address));
+
+ else
+ declare
+ Pos : Nat;
+
+ begin
+ if not Static_Dispatch_Tables then
+ Nb_Predef_Prims := Max_Predef_Prims;
+
+ else
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ if Is_Predefined_Dispatching_Operation (Prim)
+ and then not Is_Abstract_Subprogram (Prim)
+ then
+ Pos := UI_To_Int (DT_Position (Prim));
+
+ if Pos > Nb_Predef_Prims then
+ Nb_Predef_Prims := Pos;
+ end if;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end if;
+
+ declare
+ Prim_Table : array
+ (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
+ E : Entity_Id;
+
+ begin
+ Prim_Ops_Aggr_List := New_List;
+
+ Prim_Table := (others => Empty);
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ if Static_Dispatch_Tables
+ and then Is_Predefined_Dispatching_Operation (Prim)
+ and then not Is_Abstract_Subprogram (Prim)
+ and then not Present (Prim_Table
+ (UI_To_Int (DT_Position (Prim))))
+ then
+ E := Prim;
+ while Present (Alias (E)) loop
+ E := Alias (E);
+ end loop;
+
+ pragma Assert (not Is_Abstract_Subprogram (E));
+ Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ for J in Prim_Table'Range loop
+ if Present (Prim_Table (J)) then
+ New_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Prim_Table (J), Loc),
+ Attribute_Name => Name_Address);
+ else
+ New_Node := New_Reference_To (RTE (RE_Null_Address), Loc);
+ end if;
+
+ Append_To (Prim_Ops_Aggr_List, New_Node);
+ end loop;
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Predef_Prims,
+ Aliased_Present => True,
+ Constant_Present => Static_Dispatch_Tables,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Address_Array), Loc),
+ Expression => Make_Aggregate (Loc,
+ Expressions => Prim_Ops_Aggr_List)));
+
+ Append_To (Result,
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Reference_To (Predef_Prims, Loc),
+ Chars => Name_Alignment,
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (RTE (RE_Integer_Address), Loc),
+ Attribute_Name => Name_Alignment)));
+ end;
+ end;
+
+ -- Stage 1: Initialize the discriminant and the record components
+
+ DT_Constr_List := New_List;
+ DT_Aggr_List := New_List;
+
+ -- Num_Prims. If the tagged type has no primitives we add a dummy
+ -- slot whose address will be the tag of this type.
+
+ if Nb_Prim = 0 then
+ New_Node := Make_Integer_Literal (Loc, 1);
+ else
+ New_Node := Make_Integer_Literal (Loc, Nb_Prim);
+ end if;
+
+ Append_To (DT_Constr_List, New_Node);
+ Append_To (DT_Aggr_List, New_Copy (New_Node));
+
+ -- Signature
+
+ if RTE_Record_Component_Available (RE_Signature) then
+ Append_To (DT_Aggr_List,
+ New_Reference_To (RTE (RE_Primary_DT), Loc));
+ end if;
+
+ -- Tag_Kind
+
+ if RTE_Record_Component_Available (RE_Tag_Kind) then
+ Append_To (DT_Aggr_List, Tagged_Kind (Typ));
+ end if;
+
+ -- Predef_Prims
+
+ Append_To (DT_Aggr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Predef_Prims, Loc),
+ Attribute_Name => Name_Address));
+
+ -- Offset_To_Top
+
+ if RTE_Record_Component_Available (RE_Offset_To_Top) then
+ Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
+ end if;
+
+ -- Typeinfo
+
+ Append_To (DT_Aggr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (TSD, Loc),
+ Attribute_Name => Name_Address));
+
+ -- Stage 2: Initialize the table of primitive operations
+
+ Prim_Ops_Aggr_List := New_List;
+
+ if Nb_Prim = 0 then
+ Append_To (Prim_Ops_Aggr_List,
+ New_Reference_To (RTE (RE_Null_Address), Loc));
+
+ elsif not Static_Dispatch_Tables then
+ for J in 1 .. Nb_Prim loop
+ Append_To (Prim_Ops_Aggr_List,
+ New_Reference_To (RTE (RE_Null_Address), Loc));
+ end loop;
+
+ else
+ declare
+ Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
+ E : Entity_Id;
+ Prim : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+
+ begin
+ Prim_Table := (others => Empty);
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ if Is_Imported (Prim)
+ or else Present (Abstract_Interface_Alias (Prim))
+ or else Is_Predefined_Dispatching_Operation (Prim)
+ then
+ null;
+
+ else
+ -- Traverse the list of aliased entities to handle
+ -- renamings of predefined primitives.
+
+ E := Prim;
+ while Present (Alias (E)) loop
+ E := Alias (E);
+ end loop;
+
+ if not Is_Predefined_Dispatching_Operation (E)
+ and then not Is_Abstract_Subprogram (E)
+ and then not Present (Abstract_Interface_Alias (E))
+ then
+ pragma Assert
+ (UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
+
+ Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
+
+ -- There is no need to set Has_Delayed_Freeze here
+ -- because the analysis of 'Address and 'Code_Address
+ -- takes care of it.
+ end if;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ for J in Prim_Table'Range loop
+ if Present (Prim_Table (J)) then
+ New_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Prim_Table (J), Loc),
+ Attribute_Name => Name_Address);
+ else
+ New_Node := New_Reference_To (RTE (RE_Null_Address), Loc);
+ end if;
+
+ Append_To (Prim_Ops_Aggr_List, New_Node);
+ end loop;
+ end;
+ end if;
+
+ Append_To (DT_Aggr_List,
+ Make_Aggregate (Loc,
+ Expressions => Prim_Ops_Aggr_List));
+
+ -- In case of locally defined tagged types we have already declared
+ -- and uninitialized object for the dispatch table, which is now
+ -- initialized by means of an assignment.
+
+ if Is_Local_DT then
+ Append_To (Result,
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (DT, Loc),
+ Expression => Make_Aggregate (Loc,
+ Expressions => DT_Aggr_List)));
+
+ -- In case of library level tagged types we declare now the constant
+ -- object containing the dispatch table.
+
+ else
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT,
+ Aliased_Present => True,
+ Constant_Present => Static_Dispatch_Tables,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To
+ (RTE (RE_Dispatch_Table_Wrapper), Loc),
+ Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => DT_Constr_List)),
+ Expression => Make_Aggregate (Loc,
+ Expressions => DT_Aggr_List)));
+
+ 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)));
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT_Ptr,
+ Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
+ Constant_Present => True,
+ Expression =>
+ Unchecked_Convert_To (Generalized_Tag,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+ Attribute_Name => Name_Address))));
+ end if;
+ end if;
+
+ -- Initialize the table of ancestor tags
+
+ if not Is_Interface (Typ)
+ and then not Is_CPP_Class (Typ)
+ then
+ Append_To (Result,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Reference_To (TSD, Loc),
+ Selector_Name =>
+ New_Reference_To
+ (RTE_Record_Component (RE_Tags_Table), Loc)),
+ Expressions =>
+ New_List (Make_Integer_Literal (Loc, 0))),
+
+ Expression =>
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
+ end if;
+
+ if Static_Dispatch_Tables then
+ null;
+
+ -- If the ancestor is a CPP_Class type we inherit the dispatch tables
+ -- in the init proc, and we don't need to fill them in here.
+
+ elsif Is_CPP_Class (Etype (Typ)) then
+ null;
+
+ -- Otherwise we fill in the dispatch tables here
+
+ else
+ if Typ = Etype (Typ)
+ or else Is_CPP_Class (Etype (Typ))
+ or else Is_Interface (Typ)
+ then
+ Null_Parent_Tag := True;
+
+ Old_Tag1 :=
+ Unchecked_Convert_To (Generalized_Tag,
+ Make_Integer_Literal (Loc, 0));
+ Old_Tag2 :=
+ Unchecked_Convert_To (Generalized_Tag,
+ Make_Integer_Literal (Loc, 0));
+
+ else
+ Old_Tag1 :=
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
+ Old_Tag2 :=
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
+ end if;
+
+ if Typ /= Etype (Typ)
+ and then not Is_Interface (Typ)
+ and then not Restriction_Active (No_Dispatching_Calls)
+ then
+ -- Inherit the dispatch table
+
+ if not Is_Interface (Etype (Typ)) then
+ if not Null_Parent_Tag then
+ declare
+ Nb_Prims : constant Int :=
+ UI_To_Int (DT_Entry_Count
+ (First_Tag_Component (Etype (Typ))));
+ begin
+ Append_To (Elab_Code,
+ Build_Inherit_Predefined_Prims (Loc,
+ Old_Tag_Node => Old_Tag1,
+ New_Tag_Node =>
+ New_Reference_To (DT_Ptr, Loc)));
+
+ if Nb_Prims /= 0 then
+ Append_To (Elab_Code,
+ Build_Inherit_Prims (Loc,
+ Old_Tag_Node => Old_Tag2,
+ New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
+ Num_Prims => Nb_Prims));
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- Inherit the secondary dispatch tables of the ancestor
+
+ if not Is_CPP_Class (Etype (Typ)) then
+ declare
+ Sec_DT_Ancestor : Elmt_Id :=
+ Next_Elmt
+ (First_Elmt
+ (Access_Disp_Table (Etype (Typ))));
+ Sec_DT_Typ : Elmt_Id :=
+ Next_Elmt
+ (First_Elmt
+ (Access_Disp_Table (Typ)));
+
+ procedure Copy_Secondary_DTs (Typ : Entity_Id);
+ -- Local procedure required to climb through the ancestors
+ -- and copy the contents of all their secondary dispatch
+ -- tables.
+
+ ------------------------
+ -- Copy_Secondary_DTs --
+ ------------------------
+
+ procedure Copy_Secondary_DTs (Typ : Entity_Id) is
+ E : Entity_Id;
+ Iface : Elmt_Id;
+
+ begin
+ -- Climb to the ancestor (if any) handling private types
+
+ if Present (Full_View (Etype (Typ))) then
+ if Full_View (Etype (Typ)) /= Typ then
+ Copy_Secondary_DTs (Full_View (Etype (Typ)));
+ end if;
+
+ elsif Etype (Typ) /= Typ then
+ Copy_Secondary_DTs (Etype (Typ));
+ end if;
+
+ if Present (Abstract_Interfaces (Typ))
+ and then not Is_Empty_Elmt_List
+ (Abstract_Interfaces (Typ))
+ then
+ Iface := First_Elmt (Abstract_Interfaces (Typ));
+ E := First_Entity (Typ);
+ while Present (E)
+ and then Present (Node (Sec_DT_Ancestor))
+ and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
+ loop
+ if Is_Tag (E) and then Chars (E) /= Name_uTag then
+ if not Is_Interface (Etype (Typ)) then
+
+ -- Inherit the dispatch table
+
+ declare
+ Num_Prims : constant Int :=
+ UI_To_Int (DT_Entry_Count (E));
+ begin
+ Append_To (Elab_Code,
+ Build_Inherit_Predefined_Prims (Loc,
+ Old_Tag_Node =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node (Sec_DT_Ancestor), Loc)),
+ New_Tag_Node =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node (Sec_DT_Typ), Loc))));
+
+ if Num_Prims /= 0 then
+ Append_To (Elab_Code,
+ Build_Inherit_Prims (Loc,
+ Old_Tag_Node =>
+ Unchecked_Convert_To
+ (RTE (RE_Tag),
+ New_Reference_To
+ (Node (Sec_DT_Ancestor),
+ Loc)),
+ New_Tag_Node =>
+ Unchecked_Convert_To
+ (RTE (RE_Tag),
+ New_Reference_To
+ (Node (Sec_DT_Typ), Loc)),
+ Num_Prims => Num_Prims));
+ end if;
+ end;
+ end if;
+
+ Next_Elmt (Sec_DT_Ancestor);
+ Next_Elmt (Sec_DT_Typ);
+ Next_Elmt (Iface);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end if;
+ end Copy_Secondary_DTs;
+
+ begin
+ if Present (Node (Sec_DT_Ancestor))
+ and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
+ then
+ -- Handle private types
+
+ if Present (Full_View (Typ)) then
+ Copy_Secondary_DTs (Full_View (Typ));
+ else
+ Copy_Secondary_DTs (Typ);
+ end if;
+ end if;
+ end;
+ end if;
+ end if;
+ end if;
+
+ -- Generate code to register the Tag in the External_Tag hash table for
+ -- the pure Ada type only.
+
+ -- Register_Tag (Dt_Ptr);
+
+ -- Skip this action in the following cases:
+ -- 1) if Register_Tag is not available.
+ -- 2) in No_Run_Time mode.
+ -- 3) if Typ is an abstract interface type (the secondary tags will
+ -- be registered later in types implementing this interface type).
+ -- 4) if Typ is not defined at the library level (this is required
+ -- to avoid adding concurrency control to the hash table used
+ -- by the run-time to register the tags).
+
+ -- Generate:
+ -- if No_Reg then
+ -- [ Elab_Code ]
+ -- [ Register_Tag (Dt_Ptr); ]
+ -- No_Reg := False;
+ -- end if;
+
+ if not Is_Interface (Typ) then
+ if not No_Run_Time_Mode
+ and then not Is_Local_DT
+ and then RTE_Available (RE_Register_Tag)
+ 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;
+
+ 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));
+ end if;
+
+ Analyze_List (Result, Suppress => All_Checks);
+ return Result;
+ end Make_DT;
+
+ -------------------------------------
+ -- Make_Select_Specific_Data_Table --
+ -------------------------------------
+
+ function Make_Select_Specific_Data_Table
+ (Typ : Entity_Id) return List_Id
+ is
+ Assignments : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (Typ);
+
+ Conc_Typ : Entity_Id;
+ Decls : List_Id;
+ DT_Ptr : Entity_Id;
+ Prim : Entity_Id;
+ Prim_Als : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ Prim_Pos : Uint;
+ Nb_Prim : Nat := 0;
+
+ type Examined_Array is array (Int range <>) of Boolean;
+
+ function Find_Entry_Index (E : Entity_Id) return Uint;
+ -- Given an entry, find its index in the visible declarations of the
+ -- corresponding concurrent type of Typ.
+
+ ----------------------
+ -- Find_Entry_Index --
+ ----------------------
+
+ function Find_Entry_Index (E : Entity_Id) return Uint is
+ Index : Uint := Uint_1;
+ Subp_Decl : Entity_Id;
+
+ begin
+ if Present (Decls)
+ and then not Is_Empty_List (Decls)
+ then
+ Subp_Decl := First (Decls);
+ while Present (Subp_Decl) loop
+ if Nkind (Subp_Decl) = N_Entry_Declaration then
+ if Defining_Identifier (Subp_Decl) = E then
+ return Index;
+ end if;
+
+ Index := Index + 1;
+ end if;
+
+ Next (Subp_Decl);
+ end loop;
+ end if;
+
+ return Uint_0;
+ end Find_Entry_Index;
+
+ -- Start of processing for Make_Select_Specific_Data_Table
+
+ begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+
+ if Present (Corresponding_Concurrent_Type (Typ)) then
+ Conc_Typ := Corresponding_Concurrent_Type (Typ);
+
+ if Ekind (Conc_Typ) = E_Protected_Type then
+ Decls := Visible_Declarations (Protected_Definition (
+ Parent (Conc_Typ)));
+ else
+ pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
+ Decls := Visible_Declarations (Task_Definition (
+ Parent (Conc_Typ)));
+ end if;
+ end if;
+
+ -- Count the non-predefined primitive operations
+
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ if not (Is_Predefined_Dispatching_Operation (Prim)
+ or else Is_Predefined_Dispatching_Alias (Prim))
+ then
+ Nb_Prim := Nb_Prim + 1;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ declare
+ Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
+
+ begin
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ -- Look for primitive overriding an abstract interface subprogram
+
+ if Present (Abstract_Interface_Alias (Prim))
+ and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
+ then
+ Prim_Pos := DT_Position (Alias (Prim));
+ pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
+ Examined (UI_To_Int (Prim_Pos)) := True;
+
+ -- Set the primitive operation kind regardless of subprogram
+ -- type. Generate:
+ -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
+
+ Append_To (Assignments,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Set_Prim_Op_Kind), Loc),
+ Parameter_Associations => New_List (
+ New_Reference_To (DT_Ptr, Loc),
+ Make_Integer_Literal (Loc, Prim_Pos),
+ Prim_Op_Kind (Alias (Prim), Typ))));
+
+ -- Retrieve the root of the alias chain
+
+ Prim_Als := Prim;
+ while Present (Alias (Prim_Als)) loop
+ Prim_Als := Alias (Prim_Als);
+ end loop;
+
+ -- In the case of an entry wrapper, set the entry index
+
+ if Ekind (Prim) = E_Procedure
+ and then Is_Primitive_Wrapper (Prim_Als)
+ and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
+ then
+ -- Generate:
+ -- Ada.Tags.Set_Entry_Index
+ -- (DT_Ptr, <position>, <index>);
+
+ Append_To (Assignments,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Set_Entry_Index), Loc),
+ Parameter_Associations => New_List (
+ New_Reference_To (DT_Ptr, Loc),
+ Make_Integer_Literal (Loc, Prim_Pos),
+ Make_Integer_Literal (Loc,
+ Find_Entry_Index (Wrapped_Entity (Prim_Als))))));
+ end if;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end;
+
+ return Assignments;
+ end Make_Select_Specific_Data_Table;
+
+ -----------------------------------
+ -- Original_View_In_Visible_Part --
+ -----------------------------------
+
+ function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
+ Scop : constant Entity_Id := Scope (Typ);
+
+ begin
+ -- The scope must be a package
+
+ if Ekind (Scop) /= E_Package
+ and then Ekind (Scop) /= E_Generic_Package
+ then
+ return False;
+ end if;
+
+ -- A type with a private declaration has a private view declared in
+ -- the visible part.
+
+ if Has_Private_Declaration (Typ) then
+ return True;
+ end if;
+
+ return List_Containing (Parent (Typ)) =
+ Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
+ end Original_View_In_Visible_Part;
+
+ ------------------
+ -- Prim_Op_Kind --
+ ------------------
+
+ function Prim_Op_Kind
+ (Prim : Entity_Id;
+ Typ : Entity_Id) return Node_Id
+ is
+ Full_Typ : Entity_Id := Typ;
+ Loc : constant Source_Ptr := Sloc (Prim);
+ Prim_Op : Entity_Id;
+
+ begin
+ -- Retrieve the original primitive operation
+
+ Prim_Op := Prim;
+ while Present (Alias (Prim_Op)) loop
+ Prim_Op := Alias (Prim_Op);
+ end loop;
+
+ if Ekind (Typ) = E_Record_Type
+ and then Present (Corresponding_Concurrent_Type (Typ))
+ then
+ Full_Typ := Corresponding_Concurrent_Type (Typ);
+ end if;
+
+ if Ekind (Prim_Op) = E_Function then
+
+ -- Protected function
+
+ if Ekind (Full_Typ) = E_Protected_Type then
+ return New_Reference_To (RTE (RE_POK_Protected_Function), Loc);
+
+ -- Task function
+
+ elsif Ekind (Full_Typ) = E_Task_Type then
+ return New_Reference_To (RTE (RE_POK_Task_Function), Loc);
+
+ -- Regular function
+
+ else
+ return New_Reference_To (RTE (RE_POK_Function), Loc);
+ end if;
+
+ else
+ pragma Assert (Ekind (Prim_Op) = E_Procedure);
+
+ if Ekind (Full_Typ) = E_Protected_Type then
+
+ -- Protected entry
+
+ if Is_Primitive_Wrapper (Prim_Op)
+ and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
+ then
+ return New_Reference_To (RTE (RE_POK_Protected_Entry), Loc);
+
+ -- Protected procedure
+
+ else
+ return New_Reference_To (RTE (RE_POK_Protected_Procedure), Loc);
+ end if;
+
+ elsif Ekind (Full_Typ) = E_Task_Type then
+
+ -- Task entry
+
+ if Is_Primitive_Wrapper (Prim_Op)
+ and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
+ then
+ return New_Reference_To (RTE (RE_POK_Task_Entry), Loc);
+
+ -- Task "procedure". These are the internally Expander-generated
+ -- procedures (task body for instance).
+
+ else
+ return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc);
+ end if;
+
+ -- Regular procedure
+
+ else
+ return New_Reference_To (RTE (RE_POK_Procedure), Loc);
+ end if;
+ end if;
+ end Prim_Op_Kind;
+
+ ------------------------
+ -- Register_Primitive --
+ ------------------------
+
+ procedure Register_Primitive
+ (Loc : Source_Ptr;
+ Prim : Entity_Id;
+ Ins_Nod : Node_Id)
+ is
+ DT_Ptr : Entity_Id;
+ Iface_Prim : Entity_Id;
+ Iface_Typ : Entity_Id;
+ Iface_DT_Ptr : Entity_Id;
+ Pos : Uint;
+ Tag : Entity_Id;
+ Thunk_Id : Entity_Id;
+ Thunk_Code : Node_Id;
+ Typ : Entity_Id;
+
+ begin
+ pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+
+ if not RTE_Available (RE_Tag) then
+ return;
+ end if;
+
+ if not Present (Abstract_Interface_Alias (Prim)) then
+ Typ := Scope (DTC_Entity (Prim));
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+ Pos := DT_Position (Prim);
+ Tag := First_Tag_Component (Typ);
+
+ if Is_Predefined_Dispatching_Operation (Prim)
+ or else Is_Predefined_Dispatching_Alias (Prim)
+ then
+ Insert_After (Ins_Nod,
+ Build_Set_Predefined_Prim_Op_Address (Loc,
+ Tag_Node => New_Reference_To (DT_Ptr, Loc),
+ Position => Pos,
+ Address_Node => Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Prim, Loc),
+ Attribute_Name => Name_Address)));
+
+ else
+ pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
+
+ Insert_After (Ins_Nod,
+ Build_Set_Prim_Op_Address (Loc,
+ Typ => Typ,
+ Tag_Node => New_Reference_To (DT_Ptr, Loc),
+ Position => Pos,
+ Address_Node => Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Prim, Loc),
+ Attribute_Name => Name_Address)));
+ end if;
+
+ -- Ada 2005 (AI-251): Primitive associated with an interface type
+ -- Generate the code of the thunk only if the interface type is not an
+ -- immediate ancestor of Typ; otherwise the dispatch table associated
+ -- with the interface is the primary dispatch table and we have nothing
+ -- else to do here.
+
+ else
+ Typ := Find_Dispatching_Type (Alias (Prim));
+ Iface_Typ := Find_Dispatching_Type (Abstract_Interface_Alias (Prim));
+
+ pragma Assert (Is_Interface (Iface_Typ));
+
+ Expand_Interface_Thunk
+ (N => Prim,
+ Thunk_Alias => Alias (Prim),
+ Thunk_Id => Thunk_Id,
+ Thunk_Code => Thunk_Code);
+
+ if not Is_Parent (Iface_Typ, Typ)
+ and then Present (Thunk_Code)
+ then
+ Insert_Action (Ins_Nod, Thunk_Code, Suppress => All_Checks);
+
+ -- Generate the code necessary to fill the appropriate entry of
+ -- the secondary dispatch table of Prim's controlling type with
+ -- Thunk_Id's address.
+
+ Iface_DT_Ptr := Find_Interface_ADT (Typ, Iface_Typ);
+ Iface_Prim := Abstract_Interface_Alias (Prim);
+ Pos := DT_Position (Iface_Prim);
+ Tag := First_Tag_Component (Iface_Typ);
+
+ if Is_Predefined_Dispatching_Operation (Prim)
+ or else Is_Predefined_Dispatching_Alias (Prim)
+ then
+ Insert_Action (Ins_Nod,
+ Build_Set_Predefined_Prim_Op_Address (Loc,
+ Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
+ Position => Pos,
+ Address_Node =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Thunk_Id, Loc),
+ Attribute_Name => Name_Address)));
+ else
+ pragma Assert (Pos /= Uint_0
+ and then Pos <= DT_Entry_Count (Tag));
+
+ Insert_Action (Ins_Nod,
+ Build_Set_Prim_Op_Address (Loc,
+ Typ => Iface_Typ,
+ Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
+ Position => Pos,
+ Address_Node => Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (Thunk_Id, Loc),
+ Attribute_Name => Name_Address)));
+ end if;
+ end if;
+ end if;
+ end Register_Primitive;
+
+ -------------------------
+ -- Set_All_DT_Position --
+ -------------------------
- 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;
+ procedure Set_All_DT_Position (Typ : Entity_Id) is
- begin
- if Is_CPP_Class (Root_Type (Typ)) then
- Action_Name := RTE (CPP_Actions (Action));
- else
- Action_Name := RTE (Ada_Actions (Action));
- end if;
+ procedure Validate_Position (Prim : Entity_Id);
+ -- Check that the position assignated to Prim is completely safe
+ -- (it has not been assigned to a previously defined primitive
+ -- operation of Typ)
- if No (Args) then
+ -----------------------
+ -- Validate_Position --
+ -----------------------
- -- This is a constant
+ procedure Validate_Position (Prim : Entity_Id) is
+ Op_Elmt : Elmt_Id;
+ Op : Entity_Id;
- return New_Reference_To (Action_Name, Sloc (Typ));
- end if;
+ begin
+ -- Aliased primitives are safe
- pragma Assert (List_Length (Args) = Action_Nb_Arg (Action));
+ if Present (Alias (Prim)) then
+ return;
+ end if;
- Loc := Sloc (First (Args));
+ Op_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Op_Elmt) loop
+ Op := Node (Op_Elmt);
- if Action_Is_Proc (Action) then
- return
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (Action_Name, Loc),
- Parameter_Associations => Args);
+ -- No need to check against itself
- else
- return
- Make_Function_Call (Loc,
- Name => New_Reference_To (Action_Name, Loc),
- Parameter_Associations => Args);
- end if;
- end Make_DT_Access_Action;
+ if Op = Prim then
+ null;
- -----------------------------------
- -- Original_View_In_Visible_Part --
- -----------------------------------
+ -- Primitive operations covering abstract interfaces are
+ -- allocated later
- function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
- Scop : constant Entity_Id := Scope (Typ);
+ elsif Present (Abstract_Interface_Alias (Op)) then
+ null;
- begin
- -- The scope must be a package
+ -- Predefined dispatching operations are completely safe. They
+ -- are allocated at fixed positions in a separate table.
- if Ekind (Scop) /= E_Package
- and then Ekind (Scop) /= E_Generic_Package
- then
- return False;
- end if;
+ elsif Is_Predefined_Dispatching_Operation (Op)
+ or else Is_Predefined_Dispatching_Alias (Op)
+ then
+ null;
- -- A type with a private declaration has a private view declared in
- -- the visible part.
+ -- Aliased subprograms are safe
- if Has_Private_Declaration (Typ) then
- return True;
- end if;
+ elsif Present (Alias (Op)) then
+ null;
- return List_Containing (Parent (Typ)) =
- Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
- end Original_View_In_Visible_Part;
+ elsif DT_Position (Op) = DT_Position (Prim)
+ and then not Is_Predefined_Dispatching_Operation (Op)
+ and then not Is_Predefined_Dispatching_Operation (Prim)
+ and then not Is_Predefined_Dispatching_Alias (Op)
+ and then not Is_Predefined_Dispatching_Alias (Prim)
+ then
- -------------------------
- -- Set_All_DT_Position --
- -------------------------
+ -- Handle aliased subprograms
+
+ declare
+ Op_1 : Entity_Id;
+ Op_2 : Entity_Id;
+
+ begin
+ Op_1 := Op;
+ loop
+ if Present (Overridden_Operation (Op_1)) then
+ Op_1 := Overridden_Operation (Op_1);
+ elsif Present (Alias (Op_1)) then
+ Op_1 := Alias (Op_1);
+ else
+ exit;
+ end if;
+ end loop;
+
+ Op_2 := Prim;
+ loop
+ if Present (Overridden_Operation (Op_2)) then
+ Op_2 := Overridden_Operation (Op_2);
+ elsif Present (Alias (Op_2)) then
+ Op_2 := Alias (Op_2);
+ else
+ exit;
+ end if;
+ end loop;
+
+ if Op_1 /= Op_2 then
+ raise Program_Error;
+ end if;
+ end;
+ end if;
+
+ Next_Elmt (Op_Elmt);
+ end loop;
+ end Validate_Position;
+
+ -- Local variables
- procedure Set_All_DT_Position (Typ : Entity_Id) is
Parent_Typ : constant Entity_Id := Etype (Typ);
- Root_Typ : constant Entity_Id := Root_Type (Typ);
First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
The_Tag : constant Entity_Id := First_Tag_Component (Typ);
+
Adjusted : Boolean := False;
Finalized : Boolean := False;
- Parent_EC : Int;
- Nb_Prim : Int;
+
+ Count_Prim : Nat;
+ DT_Length : Nat;
+ Nb_Prim : Nat;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
+ -- Start of processing for Set_All_DT_Position
+
begin
+ -- Set the DT_Position for each primitive operation. Perform some
+ -- sanity checks to avoid to build completely inconsistant dispatch
+ -- tables.
- -- Get Entry_Count of the parent
+ -- First stage: Set the DTC entity of all the primitive operations
+ -- This is required to properly read the DT_Position attribute in
+ -- the latter stages.
- if Parent_Typ /= Typ
- and then DT_Entry_Count (First_Tag_Component (Parent_Typ)) /= No_Uint
- then
- Parent_EC := UI_To_Int (DT_Entry_Count
- (First_Tag_Component (Parent_Typ)));
- else
- Parent_EC := 0;
- end if;
+ Prim_Elmt := First_Prim;
+ Count_Prim := 0;
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
- -- C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable
- -- give a coherent set of information
+ -- Predefined primitives have a separate dispatch table
- if Is_CPP_Class (Root_Typ) then
+ if not (Is_Predefined_Dispatching_Operation (Prim)
+ or else Is_Predefined_Dispatching_Alias (Prim))
+ then
+ Count_Prim := Count_Prim + 1;
+ end if;
- -- 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
+ Set_DTC_Entity_Value (Typ, Prim);
- Prim_Elmt := First_Prim;
- Nb_Prim := 0;
- while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
+ -- Clear any previous value of the DT_Position attribute. In this
+ -- way we ensure that the final position of all the primitives is
+ -- stablished by the following stages of this algorithm.
- if not Is_CPP_Class (Typ) then
- Set_DTC_Entity (Prim, The_Tag);
+ Set_DT_Position (Prim, No_Uint);
- elsif Present (Alias (Prim)) then
- Set_DTC_Entity (Prim, DTC_Entity (Alias (Prim)));
- Set_DT_Position (Prim, DT_Position (Alias (Prim)));
+ Next_Elmt (Prim_Elmt);
+ end loop;
- 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;
+ declare
+ Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean
+ := (others => False);
+ E : Entity_Id;
+
+ procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id);
+ -- Called if Typ is declared in a nested package or a public child
+ -- package to handle inherited primitives that were inherited by Typ
+ -- in the visible part, but whose declaration was deferred because
+ -- the parent operation was private and not visible at that point.
+
+ procedure Set_Fixed_Prim (Pos : Nat);
+ -- Sets to true an element of the Fixed_Prim table to indicate
+ -- that this entry of the dispatch table of Typ is occupied.
+
+ ------------------------------------------
+ -- Handle_Inherited_Private_Subprograms --
+ ------------------------------------------
+
+ procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is
+ Op_List : Elist_Id;
+ Op_Elmt : Elmt_Id;
+ Op_Elmt_2 : Elmt_Id;
+ Prim_Op : Entity_Id;
+ Parent_Subp : Entity_Id;
- if DTC_Entity (Prim) = The_Tag then
+ begin
+ Op_List := Primitive_Operations (Typ);
- -- Get the slot from the parent subprogram if any
+ Op_Elmt := First_Elmt (Op_List);
+ while Present (Op_Elmt) loop
+ Prim_Op := Node (Op_Elmt);
- declare
- H : Entity_Id := Homonym (Prim);
+ -- Search primitives that are implicit operations with an
+ -- internal name whose parent operation has a normal name.
- begin
- while Present (H) loop
- if Present (DTC_Entity (H))
- and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ
+ if Present (Alias (Prim_Op))
+ and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ
+ and then not Comes_From_Source (Prim_Op)
+ and then Is_Internal_Name (Chars (Prim_Op))
+ and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
+ then
+ Parent_Subp := Alias (Prim_Op);
+
+ -- Check if the type has an explicit overriding for this
+ -- primitive.
+
+ Op_Elmt_2 := Next_Elmt (Op_Elmt);
+ while Present (Op_Elmt_2) loop
+ if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
+ and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
then
- Set_DT_Position (Prim, DT_Position (H));
- exit;
+ Set_DT_Position (Prim_Op, DT_Position (Parent_Subp));
+ Set_DT_Position (Node (Op_Elmt_2),
+ DT_Position (Parent_Subp));
+ Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op)));
+
+ goto Next_Primitive;
end if;
- H := Homonym (H);
+ Next_Elmt (Op_Elmt_2);
end loop;
- end;
+ end if;
- -- Otherwise take the canonical slot after the end of the
- -- parent Vtable
+ <<Next_Primitive>>
+ Next_Elmt (Op_Elmt);
+ end loop;
+ end Handle_Inherited_Private_Subprograms;
- if DT_Position (Prim) = No_Uint then
- Nb_Prim := Nb_Prim + 1;
- Set_DT_Position (Prim, UI_From_Int (Parent_EC + Nb_Prim));
+ --------------------
+ -- Set_Fixed_Prim --
+ --------------------
- elsif UI_To_Int (DT_Position (Prim)) > Parent_EC then
- Nb_Prim := Nb_Prim + 1;
- end if;
- end if;
+ procedure Set_Fixed_Prim (Pos : Nat) is
+ begin
+ pragma Assert (Pos >= 0 and then Pos <= Count_Prim);
+ Fixed_Prim (Pos) := True;
+ exception
+ when Constraint_Error =>
+ raise Program_Error;
+ end Set_Fixed_Prim;
- Next_Elmt (Prim_Elmt);
- end loop;
+ begin
+ -- In case of nested packages and public child package it may be
+ -- necessary a special management on inherited subprograms so that
+ -- the dispatch table is properly filled.
+
+ if Ekind (Scope (Scope (Typ))) = E_Package
+ and then Scope (Scope (Typ)) /= Standard_Standard
+ and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ))
+ or else
+ (Nkind (Parent (Typ)) = N_Private_Extension_Declaration
+ and then Is_Generic_Type (Typ)))
+ and then In_Open_Scopes (Scope (Etype (Typ)))
+ and then Typ = Base_Type (Typ)
+ then
+ Handle_Inherited_Private_Subprograms (Typ);
+ end if;
- -- 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)
+ -- Second stage: Register fixed entries
- 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));
+ Nb_Prim := 0;
+ Prim_Elmt := First_Prim;
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
- 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;
+ -- Predefined primitives have a separate table and all its
+ -- entries are at predefined fixed positions.
- -- Check that Positions are not duplicate nor outside the range of
- -- the Vtable
+ if Is_Predefined_Dispatching_Operation (Prim) then
+ Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
- 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);
+ elsif Is_Predefined_Dispatching_Alias (Prim) then
+ E := Alias (Prim);
+ while Present (Alias (E)) loop
+ E := Alias (E);
+ end loop;
- begin
- Prim_Elmt := First_Prim;
- while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
+ Set_DT_Position (Prim, Default_Prim_Op_Position (E));
- if DTC_Entity (Prim) = The_Tag then
- Pos := UI_To_Int (DT_Position (Prim));
+ -- Overriding primitives of ancestor abstract interfaces
- if Pos not in Prim_Pos_Table'Range then
- Error_Msg_N
- ("position not in range of virtual table", Prim);
+ elsif Present (Abstract_Interface_Alias (Prim))
+ and then Is_Parent
+ (Find_Dispatching_Type
+ (Abstract_Interface_Alias (Prim)),
+ Typ)
+ then
+ pragma Assert (DT_Position (Prim) = No_Uint
+ and then Present (DTC_Entity
+ (Abstract_Interface_Alias (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));
+ E := Abstract_Interface_Alias (Prim);
+ Set_DT_Position (Prim, DT_Position (E));
- else
- Prim_Pos_Table (Pos) := Prim;
- end if;
- end if;
+ pragma Assert
+ (DT_Position (Alias (Prim)) = No_Uint
+ or else DT_Position (Alias (Prim)) = DT_Position (E));
+ Set_DT_Position (Alias (Prim), DT_Position (E));
+ Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
- Next_Elmt (Prim_Elmt);
- end loop;
- end;
+ -- Overriding primitives must use the same entry as the
+ -- overriden primitive.
+
+ elsif not Present (Abstract_Interface_Alias (Prim))
+ and then Present (Alias (Prim))
+ and then Find_Dispatching_Type (Alias (Prim)) /= Typ
+ and then Is_Parent
+ (Find_Dispatching_Type (Alias (Prim)), Typ)
+ and then Present (DTC_Entity (Alias (Prim)))
+ then
+ E := Alias (Prim);
+ Set_DT_Position (Prim, DT_Position (E));
- -- 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.
+ if not Is_Predefined_Dispatching_Alias (E) then
+ Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
+ end if;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
- -- 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?)
+ -- Third stage: Fix the position of all the new primitives
+ -- Entries associated with primitives covering interfaces
+ -- are handled in a latter round.
- 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;
+ -- Skip primitives previously set entries
+
+ if DT_Position (Prim) /= No_Uint then
+ null;
+
+ -- Primitives covering interface primitives are handled later
+
+ elsif Present (Abstract_Interface_Alias (Prim)) then
+ null;
+
else
+ -- Take the next available position in the DT
+
+ loop
+ Nb_Prim := Nb_Prim + 1;
+ pragma Assert (Nb_Prim <= Count_Prim);
+ exit when not Fixed_Prim (Nb_Prim);
+ end loop;
+
Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
+ Set_Fixed_Prim (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))))
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end;
+
+ -- Fourth stage: Complete the decoration of primitives covering
+ -- interfaces (that is, propagate the DT_Position attribute
+ -- from the aliased primitive)
+
+ Prim_Elmt := First_Prim;
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ if DT_Position (Prim) = No_Uint
+ and then Present (Abstract_Interface_Alias (Prim))
+ then
+ pragma Assert (Present (Alias (Prim))
+ and then Find_Dispatching_Type (Alias (Prim)) = Typ);
+
+ -- Check if this entry will be placed in the primary DT
+
+ if Is_Parent (Find_Dispatching_Type
+ (Abstract_Interface_Alias (Prim)),
+ Typ)
then
- Finalized := True;
- end if;
+ pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
+ Set_DT_Position (Prim, DT_Position (Alias (Prim)));
+
+ -- Otherwise it will be placed in the secondary DT
- if Chars (Prim) = Name_Adjust then
- Adjusted := True;
+ else
+ pragma Assert
+ (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint);
+ Set_DT_Position (Prim,
+ DT_Position (Abstract_Interface_Alias (Prim)));
end if;
+ end if;
- -- 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
+ Next_Elmt (Prim_Elmt);
+ end loop;
- 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)
+ -- Generate listing showing the contents of the dispatch tables.
+ -- This action is done before some further static checks because
+ -- in case of critical errors caused by a wrong dispatch table
+ -- we need to see the contents of such table.
+
+ if Debug_Flag_ZZ then
+ Write_DT (Typ);
+ end if;
+
+ -- Final stage: Ensure that the table is correct plus some further
+ -- verifications concerning the primitives.
+
+ Prim_Elmt := First_Prim;
+ DT_Length := 0;
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ -- At this point all the primitives MUST have a position
+ -- in the dispatch table
+
+ if DT_Position (Prim) = No_Uint then
+ raise Program_Error;
+ end if;
+
+ -- Calculate real size of the dispatch table
+
+ if not (Is_Predefined_Dispatching_Operation (Prim)
+ or else Is_Predefined_Dispatching_Alias (Prim))
+ and then UI_To_Int (DT_Position (Prim)) > DT_Length
+ then
+ DT_Length := UI_To_Int (DT_Position (Prim));
+ end if;
+
+ -- Ensure that the asignated position to non-predefined
+ -- dispatching operations in the dispatch table is correct.
+
+ if not (Is_Predefined_Dispatching_Operation (Prim)
+ or else Is_Predefined_Dispatching_Alias (Prim))
+ then
+ Validate_Position (Prim);
+ end if;
+
+ if Chars (Prim) = Name_Finalize then
+ Finalized := True;
+ end if;
+
+ if Chars (Prim) = Name_Adjust then
+ Adjusted := True;
+ end if;
+
+ -- An abstract operation cannot be declared in the private part
+ -- for a visible abstract type, because it could never be over-
+ -- ridden. For explicit declarations this is checked at the
+ -- point of declaration, but for inherited operations it must
+ -- be done when building the dispatch table.
+
+ -- Ada 2005 (AI-251): Hidden entities associated with abstract
+ -- interface primitives are not taken into account because the
+ -- check is done with the aliased primitive.
+
+ if Is_Abstract_Type (Typ)
+ and then Is_Abstract_Subprogram (Prim)
+ and then Present (Alias (Prim))
+ and then not Present (Abstract_Interface_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
- -- 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;
+ Error_Msg_NE
+ ("abstract inherited private operation&" &
+ " must be overridden ('R'M 3.9.3(10))",
+ Parent (Typ), Prim);
end if;
- Next_Elmt (Prim_Elmt);
- end loop;
+ end if;
- if Is_Controlled (Typ) then
- if not Finalized then
- Error_Msg_N
- ("controlled type has no explicit Finalize method?", Typ);
+ Next_Elmt (Prim_Elmt);
+ end loop;
- elsif not Adjusted then
- Error_Msg_N
- ("controlled type has no explicit Adjust method?", Typ);
- end if;
+ -- Additional check
+
+ if Is_Controlled (Typ) then
+ if not Finalized then
+ Error_Msg_N
+ ("controlled type has no explicit Finalize method?", Typ);
+
+ elsif not Adjusted then
+ Error_Msg_N
+ ("controlled type has no explicit Adjust method?", Typ);
end if;
+ end if;
+
+ -- Set the final size of the Dispatch Table
- Set_DT_Entry_Count (The_Tag, UI_From_Int (Nb_Prim));
+ Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
- -- The derived type must have at least as many components as its
- -- parent (for root types, the Etype points back to itself
- -- and the test should not fail)
+ -- 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 cannot
+ -- fail)
- pragma Assert (
- DT_Entry_Count (The_Tag) >=
- DT_Entry_Count (First_Tag_Component (Parent_Typ)));
+ if DT_Entry_Count (The_Tag) <
+ DT_Entry_Count (First_Tag_Component (Parent_Typ))
+ then
+ raise Program_Error;
end if;
end Set_All_DT_Position;
-- won't be able to declare objects of that type.
else
- Set_Is_Abstract (Typ);
+ Set_Is_Abstract_Type (Typ);
end if;
end Set_Default_Constructor;
+ --------------------------
+ -- Set_DTC_Entity_Value --
+ --------------------------
+
+ procedure Set_DTC_Entity_Value
+ (Tagged_Type : Entity_Id;
+ Prim : Entity_Id)
+ is
+ begin
+ if Present (Abstract_Interface_Alias (Prim))
+ and then Is_Interface
+ (Find_Dispatching_Type
+ (Abstract_Interface_Alias (Prim)))
+ then
+ Set_DTC_Entity (Prim,
+ Find_Interface_Tag
+ (T => Tagged_Type,
+ Iface => Find_Dispatching_Type
+ (Abstract_Interface_Alias (Prim))));
+ else
+ Set_DTC_Entity (Prim,
+ First_Tag_Component (Tagged_Type));
+ end if;
+ end Set_DTC_Entity_Value;
+
+ -----------------
+ -- Tagged_Kind --
+ -----------------
+
+ function Tagged_Kind (T : Entity_Id) return Node_Id is
+ Conc_Typ : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (T);
+
+ begin
+ pragma Assert
+ (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));
+
+ -- Abstract kinds
+
+ if Is_Abstract_Type (T) then
+ if Is_Limited_Record (T) then
+ return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
+ else
+ return New_Reference_To (RTE (RE_TK_Abstract_Tagged), Loc);
+ end if;
+
+ -- Concurrent kinds
+
+ elsif Is_Concurrent_Record_Type (T) then
+ Conc_Typ := Corresponding_Concurrent_Type (T);
+
+ if Ekind (Conc_Typ) = E_Protected_Type then
+ return New_Reference_To (RTE (RE_TK_Protected), Loc);
+ else
+ pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
+ return New_Reference_To (RTE (RE_TK_Task), Loc);
+ end if;
+
+ -- Regular tagged kinds
+
+ else
+ if Is_Limited_Record (T) then
+ return New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc);
+ else
+ return New_Reference_To (RTE (RE_TK_Tagged), Loc);
+ end if;
+ end if;
+ end Tagged_Kind;
+
+ --------------
+ -- Write_DT --
+ --------------
+
+ procedure Write_DT (Typ : Entity_Id) is
+ Elmt : Elmt_Id;
+ Prim : Node_Id;
+
+ begin
+ -- Protect this procedure against wrong usage. Required because it will
+ -- be used directly from GDB
+
+ if not (Typ in First_Node_Id .. Last_Node_Id)
+ or else not Is_Tagged_Type (Typ)
+ then
+ Write_Str ("wrong usage: Write_DT must be used with tagged types");
+ Write_Eol;
+ return;
+ end if;
+
+ Write_Int (Int (Typ));
+ Write_Str (": ");
+ Write_Name (Chars (Typ));
+
+ if Is_Interface (Typ) then
+ Write_Str (" is interface");
+ end if;
+
+ Write_Eol;
+
+ Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Elmt) loop
+ Prim := Node (Elmt);
+ Write_Str (" - ");
+
+ -- Indicate if this primitive will be allocated in the primary
+ -- dispatch table or in a secondary dispatch table associated
+ -- with an abstract interface type
+
+ if Present (DTC_Entity (Prim)) then
+ if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
+ Write_Str ("[P] ");
+ else
+ Write_Str ("[s] ");
+ end if;
+ end if;
+
+ -- Output the node of this primitive operation and its name
+
+ Write_Int (Int (Prim));
+ Write_Str (": ");
+
+ if Is_Predefined_Dispatching_Operation (Prim) then
+ Write_Str ("(predefined) ");
+ end if;
+
+ Write_Name (Chars (Prim));
+
+ -- Indicate if this primitive has an aliased primitive
+
+ if Present (Alias (Prim)) then
+ Write_Str (" (alias = ");
+ Write_Int (Int (Alias (Prim)));
+
+ -- If the DTC_Entity attribute is already set we can also output
+ -- the name of the interface covered by this primitive (if any)
+
+ if Present (DTC_Entity (Alias (Prim)))
+ and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
+ then
+ Write_Str (" from interface ");
+ Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
+ end if;
+
+ if Present (Abstract_Interface_Alias (Prim)) then
+ Write_Str (", AI_Alias of ");
+ Write_Name (Chars (Scope (DTC_Entity
+ (Abstract_Interface_Alias (Prim)))));
+ Write_Char (':');
+ Write_Int (Int (Abstract_Interface_Alias (Prim)));
+ end if;
+
+ Write_Str (")");
+ end if;
+
+ -- Display the final position of this primitive in its associated
+ -- (primary or secondary) dispatch table
+
+ if Present (DTC_Entity (Prim))
+ and then DT_Position (Prim) /= No_Uint
+ then
+ Write_Str (" at #");
+ Write_Int (UI_To_Int (DT_Position (Prim)));
+ end if;
+
+ if Is_Abstract_Subprogram (Prim) then
+ Write_Str (" is abstract;");
+
+ -- Check if this is a null primitive
+
+ elsif Comes_From_Source (Prim)
+ and then Ekind (Prim) = E_Procedure
+ and then Null_Present (Parent (Prim))
+ then
+ Write_Str (" is null;");
+ end if;
+
+ Write_Eol;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end Write_DT;
+
end Exp_Disp;
OSDN Git Service
