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