Skip to content

R
riscv-gcc-1
Commit b0efe69e by Javier Miranda Committed by Arnaud Charlet
Options

exp_disp.ads, [...] (Expand_Dispatching_Call): If the controlling argument of… 

exp_disp.ads, [...] (Expand_Dispatching_Call): If the controlling argument of the dispatching call is an abstract interface...

2006-02-13  Javier Miranda  <miranda@adacore.com>

	* exp_disp.ads, exp_disp.adb (Expand_Dispatching_Call): If the
	controlling argument of the dispatching call is an abstract interface
	class-wide type then we use it directly.
	Check No_Dispatching_Calls restriction.
	(Default_Prim_Op_Position): Remove the code that looks for the last
	entity in the list of aliased subprograms. This code was wrong in
	case of renamings.
	(Fill_DT_Entry): Add assertion to avoid the use of this subprogram
	when the source is compiled with the No_Dispatching_Calls restriction.
	(Init_Predefined_Interface_Primitives): No need to inherit primitives
	if we are compiling with restriction No_Dispatching_Calls.
	(Make_Disp_XXX): Addition of assertion to avoid the use of all these
	subprograms if we are compiling under No_Dispatching_Calls restriction.
	(Make_DT): Generate a dispatch table with a single dummy entry if
	we are compiling with the No_Dispatching_Calls restriction. In
	addition, in this case we don't generate code that calls to the
	following run-time subprograms: Set_Type_Kind, Inherit_DT.
	(Make_Select_Specific_Data_Table): Add assertion to avoid the use
	of this subprogram if compiling with the No_Dispatching_Calls
	restriction.
	(Expand_Type_Conversion): Instead of using the actual parameter,
	the argument passed as parameter to the conversion function was
	erroneously referenced by the expander.
	(Ada_Actions): Addition of Get_Predefined_Prim_Op_Address,
	Set_Predefined_Primitive_Op_Address and Set_Signature.
	(Expand_Dispatching_Call): Generate call to
	Get_Predefined_Prim_Op_Address for predefined primitives.
	(Fill_DT_Entry): Generate call to Set_Predefined_Prim_Op_Address for
	predefined primitives.
	(Make_DT, Make_Secondary_DT): If the tagged type has no user defined
	primitives we reserve one dummy entry to ensure that the tag does not
	point to some memory that is associated with some other object. In
	addition, remove all the old code that generated the assignments
	associated with the signature of the dispatch table and replace them
	by a call to the new subprogram Set_Signature.
	(Set_All_DT_Position): Change the algorithm because now we have a
	separate dispatch table associated with predefined primitive operations.
	(Expand_Interface_Conversion): In case of non-static offset_to_top
	add explicit dereference to get access to the object after the call
	to displace the pointer to the object.
	(Expand_Interface_Thunk): Modify the generation of the actual used
	in the calls to the run-time function Offset_To_Top to fulfil its
	new interface.
	(Make_DT): Add the new actuals required to call Set_Offset_To_Top.

From-SVN: r111064
parent e5cfd2f7
Showing with 565 additions and 441 deletions
gcc/ada/exp_disp.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- 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- --
......@@ -40,6 +40,8 @@ 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;
......@@ -302,113 +304,122 @@ package body Exp_Disp is
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_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_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_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);
(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_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_Prim_Op_Address => True,
Set_Prim_Op_Kind => True,
Set_RC_Offset => True,
Set_Remotely_Callable => True,
Set_SSD => True,
Set_TSD => True,
Set_Tagged_Kind => True,
TSD_Entry_Size => False,
TSD_Prologue_Size => False);
(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_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_Prim_Op_Address => 3,
Set_Prim_Op_Kind => 3,
Set_RC_Offset => 2,
Set_Remotely_Callable => 2,
Set_SSD => 2,
Set_TSD => 2,
Set_Tagged_Kind => 2,
TSD_Entry_Size => 0,
TSD_Prologue_Size => 0);
(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 (Subp : Entity_Id) return Uint;
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.
......@@ -453,7 +464,7 @@ package body Exp_Disp is
Next_Elmt (Elmt);
end loop;
if not Present (Elmt) then
if No (Elmt) then
Append_Elmt (Iface, Abstract_Interfaces (T));
end if;
end Add_Interface;
......@@ -520,17 +531,10 @@ package body Exp_Disp is
-- Default_Prim_Op_Position --
------------------------------
function Default_Prim_Op_Position (Subp : Entity_Id) return Uint is
function Default_Prim_Op_Position (E : Entity_Id) return Uint is
TSS_Name : TSS_Name_Type;
E : Entity_Id := Subp;
begin
-- Handle overriden subprograms
while Present (Alias (E)) loop
E := Alias (E);
end loop;
Get_Name_String (Chars (E));
TSS_Name :=
TSS_Name_Type
......@@ -672,6 +676,8 @@ package body Exp_Disp is
-- 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.
......@@ -702,7 +708,8 @@ package body Exp_Disp is
-- implementation of AI-260 (for the generic dispatching constructors).
if Etype (Ctrl_Arg) = RTE (RE_Tag)
or else Etype (Ctrl_Arg) = RTE (RE_Interface_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));
......@@ -739,7 +746,6 @@ package body Exp_Disp is
-- Generate the Tag checks when appropriate
New_Params := New_List;
Param := First_Actual (Call_Node);
while Present (Param) loop
......@@ -825,7 +831,7 @@ package body Exp_Disp is
-- Generate the appropriate subprogram pointer type
if Etype (Subp) = Typ then
if Etype (Subp) = Typ then
Res_Typ := CW_Typ;
else
Res_Typ := Etype (Subp);
......@@ -909,12 +915,20 @@ package body Exp_Disp is
Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
-- If the controlling argument is a value of type Ada.Tag then
-- use it directly. Otherwise, the tag must be extracted from
-- the controlling object.
-- If the controlling argument is a value of type Ada.Tag or an abstract
-- interface class-wide type then use it directly. Otherwise, the tag
-- must be extracted from the controlling object.
if Etype (Ctrl_Arg) = RTE (RE_Tag)
or else Etype (Ctrl_Arg) = RTE (RE_Interface_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);
......@@ -928,19 +942,38 @@ package body Exp_Disp is
-- Generate:
-- Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos));
New_Call_Name :=
Unchecked_Convert_To (Subp_Ptr_Typ,
Make_DT_Access_Action (Typ,
Action => Get_Prim_Op_Address,
Args => New_List (
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
-- Vptr
Unchecked_Convert_To (RTE (RE_Tag),
Controlling_Tag),
Controlling_Tag,
-- Position
-- 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 (
Make_Integer_Literal (Loc, DT_Position (Subp)))));
-- 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
......@@ -1060,6 +1093,14 @@ package body Exp_Disp is
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),
......@@ -1086,8 +1127,10 @@ package body Exp_Disp is
Set_Directly_Designated_Type (New_Itype,
Class_Wide_Type (Iface_Typ));
Rewrite (N, Unchecked_Convert_To (New_Itype,
Relocate_Node (N)));
Rewrite (N, Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (New_Itype,
Relocate_Node (N))));
Analyze (N);
end;
return;
......@@ -1166,7 +1209,7 @@ package body Exp_Disp is
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Relocate_Node (Expression (N)),
Prefix => Make_Identifier (Loc, Name_uO),
Selector_Name =>
New_Occurrence_Of (Iface_Tag, Loc)),
Attribute_Name => Name_Address))))))));
......@@ -1455,6 +1498,13 @@ package body Exp_Disp is
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
......@@ -1501,12 +1551,10 @@ package body Exp_Disp is
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix => New_Reference_To
(Defining_Identifier (First (Formals)),
Loc),
Selector_Name => Make_Identifier (Loc,
Name_uTag))))));
Unchecked_Convert_To
(RTE (RE_Address),
New_Reference_To
(Defining_Identifier (First (Formals)), Loc))))));
Append_To (Decl, Decl_2);
Append_To (Decl, Decl_1);
......@@ -1546,12 +1594,11 @@ package body Exp_Disp is
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To
(Defining_Identifier (First (Formals)),
Loc),
Selector_Name => Make_Identifier (Loc,
Name_uTag))))));
Attribute_Name => Name_Address)))));
Decl_2 :=
Make_Object_Declaration (Loc,
......@@ -1637,22 +1684,37 @@ package body Exp_Disp is
Tag : constant Entity_Id := First_Tag_Component (Typ);
begin
if Pos = Uint_0 or else Pos > DT_Entry_Count (Tag) then
raise Program_Error;
end if;
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
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
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_Integer_Literal (Loc, Pos), -- Position
Make_Attribute_Reference (Loc, -- Value
Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Address)));
Make_Attribute_Reference (Loc, -- Value
Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Address)));
end if;
end Fill_DT_Entry;
-----------------------------
......@@ -1672,22 +1734,35 @@ package body Exp_Disp is
First_Tag_Component (Scope (DTC_Entity (Iface_Prim)));
begin
if Pos = Uint_0 or else Pos > DT_Entry_Count (Tag) then
raise Program_Error;
end if;
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
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_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));
Make_Attribute_Reference (Loc, -- Value
Prefix => New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Address)));
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;
---------------------------
......@@ -1723,7 +1798,10 @@ package body Exp_Disp is
-- 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) then
if Is_Interface (Typ)
or else Is_Concurrent_Record_Type (Typ)
or else Restriction_Active (No_Dispatching_Calls)
then
return Result;
end if;
......@@ -1734,7 +1812,7 @@ package body Exp_Disp is
-- associated with predefined primitives.
-- Generate:
-- Inherit_DT (T'Tag, Iface'Tag, Default_Prim_Op_Count);
-- Inherit_DT (T'Tag, Iface'Tag, 0);
Append_To (Result,
Make_DT_Access_Action (Typ,
......@@ -1743,7 +1821,7 @@ package body Exp_Disp is
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, Default_Prim_Op_Count))));
Node3 => Make_Integer_Literal (Loc, Uint_0))));
Next_Elmt (AI);
end loop;
......@@ -1765,6 +1843,8 @@ package body Exp_Disp is
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
......@@ -1911,6 +1991,8 @@ package body Exp_Disp is
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
......@@ -1946,6 +2028,8 @@ package body Exp_Disp is
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
......@@ -2152,6 +2236,8 @@ package body Exp_Disp is
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
......@@ -2183,6 +2269,8 @@ package body Exp_Disp is
DT_Ptr : Entity_Id;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
......@@ -2240,6 +2328,8 @@ package body Exp_Disp is
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
......@@ -2267,6 +2357,8 @@ package body Exp_Disp is
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
......@@ -2312,6 +2404,8 @@ package body Exp_Disp is
Name_uDisp_Get_Task_Id);
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
Set_Is_Internal (Def_Id);
return
......@@ -2341,6 +2435,8 @@ package body Exp_Disp is
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
......@@ -2515,6 +2611,8 @@ package body Exp_Disp is
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
......@@ -2590,6 +2688,7 @@ package body Exp_Disp is
TSD_Num_Entries : Int;
Ancestor_Copy : Entity_Id;
Empty_DT : Boolean := False;
Typ_Copy : Entity_Id;
begin
......@@ -2601,11 +2700,13 @@ package body Exp_Disp is
-- 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;
......@@ -2669,12 +2770,14 @@ package body Exp_Disp is
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 less that the number of
-- predefined primitives, we must reserve at least enough space
-- for the predefined primitives.
-- 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 < Default_Prim_Op_Count then
Nb_Prim := Default_Prim_Op_Count;
if Nb_Prim = 0 or else Restriction_Active (No_Dispatching_Calls) then
Empty_DT := True;
Nb_Prim := 1;
end if;
end if;
......@@ -2746,52 +2849,6 @@ package body Exp_Disp is
Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
-- Initialize the signature of the interface tag. It is a sequence
-- two bytes located in the header of the dispatch table.
Append_To (Result,
Make_Assignment_Statement (Loc,
Name =>
Make_Indexed_Component (Loc,
Prefix => New_Occurrence_Of (DT, Loc),
Expressions => New_List (
Make_Integer_Literal (Loc, Uint_1))),
Expression =>
Unchecked_Convert_To (RTE (RE_Storage_Element),
New_Reference_To (RTE (RE_Valid_Signature), Loc))));
if not Is_Interface (Typ) then
-- The signature of a Primary Dispatch table is:
-- (Valid_Signature, Primary_DT)
Append_To (Result,
Make_Assignment_Statement (Loc,
Name =>
Make_Indexed_Component (Loc,
Prefix => New_Occurrence_Of (DT, Loc),
Expressions => New_List (
Make_Integer_Literal (Loc, Uint_2))),
Expression =>
Unchecked_Convert_To (RTE (RE_Storage_Element),
New_Reference_To (RTE (RE_Primary_DT), Loc))));
else
-- The signature of an abstract interface is:
-- (Valid_Signature, Abstract_Interface)
Append_To (Result,
Make_Assignment_Statement (Loc,
Name =>
Make_Indexed_Component (Loc,
Prefix => New_Occurrence_Of (DT, Loc),
Expressions => New_List (
Make_Integer_Literal (Loc, Uint_2))),
Expression =>
Unchecked_Convert_To (RTE (RE_Storage_Element),
New_Reference_To (RTE (RE_Abstract_Interface), Loc))));
end if;
-- Generate code to create the pointer to the dispatch table
-- DT_Ptr : Tag := Tag!(DT'Address);
......@@ -2829,7 +2886,7 @@ package body Exp_Disp is
-- Set Access_Disp_Table field to be the dispatch table pointer
if not Present (Access_Disp_Table (Typ)) then
if No (Access_Disp_Table (Typ)) then
Set_Access_Disp_Table (Typ, New_Elmt_List);
end if;
......@@ -2876,6 +2933,26 @@ package body Exp_Disp is
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);
......@@ -2895,17 +2972,19 @@ package body Exp_Disp is
null;
elsif Num_Ifaces = 0 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
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.
else
elsif RTE_Available (RE_Set_Interface_Table) then
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => ITable,
......@@ -2932,65 +3011,77 @@ package body Exp_Disp is
-- Generate:
-- Set_Num_Prim_Ops (T'Tag, Nb_Prim)
if not Is_Interface (Typ) 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, Nb_Prim))));
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)
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 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 Is_Concurrent_Record_Type (Typ)
and then Implements_Interface (
Typ => Typ,
Kind => Any_Limited_Interface,
Check_Parent => True)
and then (Nb_Prim - Default_Prim_Op_Count) > 0
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
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 - Default_Prim_Op_Count))))));
-- Set the pointer to the Select Specific Data table in the TSD
-- Generate:
-- Set_Type_Kind (T'Tag, Type_Kind (Typ));
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Set_SSD,
Action => Set_Tagged_Kind,
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))));
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;
......@@ -3052,24 +3143,37 @@ package body Exp_Disp is
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
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)))))));
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 Is_CPP_Class (Etype (Typ)) then
if not Restriction_Active (No_Dispatching_Calls)
and then not Is_CPP_Class (Etype (Typ))
then
declare
Sec_DT_Ancestor : Elmt_Id :=
Next_Elmt
......@@ -3089,8 +3193,8 @@ package body Exp_Disp is
------------------------
procedure Copy_Secondary_DTs (Typ : Entity_Id) is
E : Entity_Id;
Iface : Elmt_Id;
E : Entity_Id;
Iface : Elmt_Id;
begin
-- Climb to the ancestor (if any) handling private types
......@@ -3110,7 +3214,6 @@ package body Exp_Disp is
then
Iface := First_Elmt (Abstract_Interfaces (Typ));
E := First_Entity (Typ);
while Present (E)
and then Present (Node (Sec_DT_Ancestor))
loop
......@@ -3168,23 +3271,24 @@ package body Exp_Disp is
Node1 => Old_Tag2,
Node2 => New_Reference_To (DT_Ptr, Loc))));
-- For types with no controlled components, generate:
-- Set_RC_Offset (DT_Ptr, 0);
if not Is_Interface (Typ) then
-- For simple types with controlled components, generate:
-- Set_RC_Offset (DT_Ptr, type._record_controller'position);
-- For types with no controlled components, generate:
-- Set_RC_Offset (DT_Ptr, 0);
-- 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
-- For simple types with controlled components, generate:
-- Set_RC_Offset (DT_Ptr, type._record_controller'position);
-- 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.
-- 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.
if not Is_Interface (Typ) then
declare
Position : Node_Id;
......@@ -3258,16 +3362,20 @@ package body Exp_Disp is
New_Occurrence_Of (Status, Loc))));
end;
-- Generate:
-- Set_Offset_To_Top (0, DT_Ptr, 0);
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),
Make_Integer_Literal (Loc, Uint_0))));
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);
......@@ -3284,15 +3392,15 @@ package body Exp_Disp is
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.
-- Generate code to register the Tag in the External_Tag hash
-- table for the pure Ada type only.
-- Register_Tag (Dt_Ptr);
-- 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)
-- 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)
......@@ -3459,6 +3567,7 @@ package body Exp_Disp 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;
......@@ -3493,14 +3602,15 @@ package body Exp_Disp is
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 less that the number of
-- predefined primitives, we must reserve at least enough space
-- for the predefined primitives.
-- 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 < Default_Prim_Op_Count then
Nb_Prim := Default_Prim_Op_Count;
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);
......@@ -3542,32 +3652,6 @@ package body Exp_Disp is
Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
-- Initialize the signature of the interface tag. It is a sequence of
-- two bytes located in the header of the dispatch table. The signature
-- of a Secondary Dispatch Table is (Valid_Signature, Secondary_DT).
Append_To (Result,
Make_Assignment_Statement (Loc,
Name =>
Make_Indexed_Component (Loc,
Prefix => New_Occurrence_Of (Iface_DT, Loc),
Expressions => New_List (
Make_Integer_Literal (Loc, Uint_1))),
Expression =>
Unchecked_Convert_To (RTE (RE_Storage_Element),
New_Reference_To (RTE (RE_Valid_Signature), Loc))));
Append_To (Result,
Make_Assignment_Statement (Loc,
Name =>
Make_Indexed_Component (Loc,
Prefix => New_Occurrence_Of (Iface_DT, Loc),
Expressions => New_List (
Make_Integer_Literal (Loc, Uint_2))),
Expression =>
Unchecked_Convert_To (RTE (RE_Storage_Element),
New_Reference_To (RTE (RE_Secondary_DT), Loc))));
-- Generate code to create the pointer to the dispatch table
-- Iface_DT_Ptr : Tag := Tag!(DT'Address);
......@@ -3607,9 +3691,16 @@ package body Exp_Disp is
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 - Default_Prim_Op_Count);
-- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims);
-- where the constraint is used to allocate space for the
-- non-predefined primitive operations only.
......@@ -3623,8 +3714,15 @@ package body Exp_Disp is
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Integer_Literal (Loc,
Nb_Prim - Default_Prim_Op_Count + 1))))));
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);
......@@ -3642,18 +3740,32 @@ package body Exp_Disp is
-- Generate:
-- Set_Num_Prim_Ops (T'Tag, Nb_Prim)
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))));
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));
......@@ -3666,12 +3778,12 @@ package body Exp_Disp is
New_Reference_To (Iface_DT_Ptr, Loc)),
Tagged_Kind (Typ)))); -- Value
if Is_Concurrent_Record_Type (Typ)
if not Empty_DT
and then Is_Concurrent_Record_Type (Typ)
and then Implements_Interface (
Typ => Typ,
Kind => Any_Limited_Interface,
Check_Parent => True)
and then (Nb_Prim - Default_Prim_Op_Count) > 0
then
declare
Prim : Entity_Id;
......@@ -3729,14 +3841,14 @@ package body Exp_Disp 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;
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;
......@@ -3776,6 +3888,8 @@ package body Exp_Disp is
-- 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
......@@ -3803,8 +3917,7 @@ package body Exp_Disp is
end loop;
declare
Examined_Size : constant Int := Nb_Prim + Default_Prim_Op_Count;
Examined : Examined_Array (1 .. Examined_Size) := (others => False);
Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
begin
Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
......@@ -3812,64 +3925,69 @@ package body Exp_Disp is
Prim := Node (Prim_Elmt);
Prim_Pos := DT_Position (Prim);
pragma Assert (UI_To_Int (Prim_Pos) <= Examined_Size);
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>);
if not Is_Predefined_Dispatching_Operation (Prim) then
pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
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;
if Examined (UI_To_Int (Prim_Pos)) then
goto Continue;
else
Prim_Als := Empty;
Examined (UI_To_Int (Prim_Pos)) := True;
end if;
-- In the case of an entry wrapper, set the entry index
-- The current primitive overrides an interface-level
-- subprogram
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
if Present (Abstract_Interface_Alias (Prim)) then
-- Generate:
-- Ada.Tags.Set_Entry_Index (DT_Ptr, <position>, <index>);
-- 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_Entry_Index,
Set_Prim_Op_Kind,
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))))));
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;
......@@ -3919,11 +4037,12 @@ package body Exp_Disp is
is
Full_Typ : Entity_Id := Typ;
Loc : constant Source_Ptr := Sloc (Prim);
Prim_Op : Entity_Id := 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;
......@@ -4037,8 +4156,8 @@ package body Exp_Disp is
if Present (Abstract_Interface_Alias (Node (Prim_Elmt))) then
null;
-- Predefined dispatching operations are completely safe.
-- They are allocated at fixed positions.
-- 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;
......@@ -4266,8 +4385,7 @@ package body Exp_Disp is
end loop;
declare
Fixed_Prim : array (Int range 0 .. Default_Prim_Op_Count +
Parent_EC + Count_Prim)
Fixed_Prim : array (Int range 0 .. Parent_EC + Count_Prim)
of Boolean := (others => False);
E : Entity_Id;
......@@ -4275,17 +4393,16 @@ package body Exp_Disp is
begin
-- Second stage: Register fixed entries
Nb_Prim := Default_Prim_Op_Count;
Nb_Prim := 0;
Prim_Elmt := First_Prim;
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
-- Predefined primitives have a fixed position in all the
-- dispatch tables
-- 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));
Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True;
-- Overriding interface primitives of an ancestor
......@@ -4355,7 +4472,10 @@ package body Exp_Disp is
-- Skip primitives previously set entries
if DT_Position (Prim) /= No_Uint then
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
......@@ -4442,14 +4562,18 @@ package body Exp_Disp is
-- Calculate real size of the dispatch table
if UI_To_Int (DT_Position (Prim)) > DT_Length then
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 in the dispatch
-- table is correct
-- Ensure that the asignated position to non-predefined
-- dispatching operations in the dispatch table is correct.
Validate_Position (Prim);
if not Is_Predefined_Dispatching_Operation (Prim) then
Validate_Position (Prim);
end if;
if Chars (Prim) = Name_Finalize then
Finalized := True;
......@@ -4591,7 +4715,8 @@ package body Exp_Disp is
Loc : constant Source_Ptr := Sloc (T);
begin
pragma Assert (Is_Tagged_Type (T));
pragma Assert
(Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));
-- Abstract kinds
......@@ -4676,6 +4801,11 @@ package body Exp_Disp is
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
......
gcc/ada/exp_disp.ads
......@@ -136,12 +136,8 @@ package Exp_Disp is
-- Guidelines for addition of new predefined primitive operations
-- Update the value of constant Default_Prim_Op_Count in Exp_Disp.ads
-- to reflect the new number of PPOs.
-- Update the value of constant Default_Prim_Op_Count in A-Tags.ads
-- to reflect the new number of PPOs. This value should be the same
-- as the one in Exp_Disp.ads.
-- to reflect the new number of PPOs.
-- Introduce a new predefined name for the new PPO in Snames.ads and
-- Snames.adb.
......@@ -149,9 +145,6 @@ package Exp_Disp is
-- Categorize the new PPO name as predefined by adding an entry in
-- Is_Predefined_Dispatching_Operation in Exp_Util.adb.
-- Reserve a dispatch table position for the new PPO by adding an entry
-- in Default_Prim_Op_Position in Exp_Disp.adb.
-- Generate the specification of the new PPO in Make_Predefined_
-- Primitive_Spec in Exp_Ch3.adb. The Is_Internal flag of the defining
-- identifier of the specification must be set to True.
......@@ -174,8 +167,6 @@ package Exp_Disp is
-- Exp_Disp.Default_Prim_Op_Position - indirect use
-- Exp_Disp.Set_All_DT_Position - direct use
Default_Prim_Op_Count : constant Int := 15;
type DT_Access_Action is
(CW_Membership,
IW_Membership,
......@@ -184,6 +175,7 @@ package Exp_Disp is
Get_Access_Level,
Get_Entry_Index,
Get_External_Tag,
Get_Predefined_Prim_Op_Address,
Get_Prim_Op_Address,
Get_Prim_Op_Kind,
Get_RC_Offset,
......@@ -200,10 +192,12 @@ package Exp_Disp is
Set_Interface_Table,
Set_Offset_Index,
Set_OSD,
Set_Predefined_Prim_Op_Address,
Set_Prim_Op_Address,
Set_Prim_Op_Kind,
Set_RC_Offset,
Set_Remotely_Callable,
Set_Signature,
Set_SSD,
Set_TSD,
Set_Tagged_Kind,
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment