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 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -40,6 +40,8 @@ with Nmake; use Nmake; ...@@ -40,6 +40,8 @@ with Nmake; use Nmake;
with Namet; use Namet; with Namet; use Namet;
with Opt; use Opt; with Opt; use Opt;
with Output; use Output; with Output; use Output;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind; with Rtsfind; use Rtsfind;
with Sem; use Sem; with Sem; use Sem;
with Sem_Disp; use Sem_Disp; with Sem_Disp; use Sem_Disp;
...@@ -302,113 +304,122 @@ package body Exp_Disp is ...@@ -302,113 +304,122 @@ package body Exp_Disp is
package SEU renames Select_Expansion_Utilities; package SEU renames Select_Expansion_Utilities;
Ada_Actions : constant array (DT_Access_Action) of RE_Id := Ada_Actions : constant array (DT_Access_Action) of RE_Id :=
(CW_Membership => RE_CW_Membership, (CW_Membership => RE_CW_Membership,
IW_Membership => RE_IW_Membership, IW_Membership => RE_IW_Membership,
DT_Entry_Size => RE_DT_Entry_Size, DT_Entry_Size => RE_DT_Entry_Size,
DT_Prologue_Size => RE_DT_Prologue_Size, DT_Prologue_Size => RE_DT_Prologue_Size,
Get_Access_Level => RE_Get_Access_Level, Get_Access_Level => RE_Get_Access_Level,
Get_Entry_Index => RE_Get_Entry_Index, Get_Entry_Index => RE_Get_Entry_Index,
Get_External_Tag => RE_Get_External_Tag, Get_External_Tag => RE_Get_External_Tag,
Get_Prim_Op_Address => RE_Get_Prim_Op_Address, Get_Predefined_Prim_Op_Address => RE_Get_Predefined_Prim_Op_Address,
Get_Prim_Op_Kind => RE_Get_Prim_Op_Kind, Get_Prim_Op_Address => RE_Get_Prim_Op_Address,
Get_RC_Offset => RE_Get_RC_Offset, Get_Prim_Op_Kind => RE_Get_Prim_Op_Kind,
Get_Remotely_Callable => RE_Get_Remotely_Callable, Get_RC_Offset => RE_Get_RC_Offset,
Get_Tagged_Kind => RE_Get_Tagged_Kind, Get_Remotely_Callable => RE_Get_Remotely_Callable,
Inherit_DT => RE_Inherit_DT, Get_Tagged_Kind => RE_Get_Tagged_Kind,
Inherit_TSD => RE_Inherit_TSD, Inherit_DT => RE_Inherit_DT,
Register_Interface_Tag => RE_Register_Interface_Tag, Inherit_TSD => RE_Inherit_TSD,
Register_Tag => RE_Register_Tag, Register_Interface_Tag => RE_Register_Interface_Tag,
Set_Access_Level => RE_Set_Access_Level, Register_Tag => RE_Register_Tag,
Set_Entry_Index => RE_Set_Entry_Index, Set_Access_Level => RE_Set_Access_Level,
Set_Expanded_Name => RE_Set_Expanded_Name, Set_Entry_Index => RE_Set_Entry_Index,
Set_External_Tag => RE_Set_External_Tag, Set_Expanded_Name => RE_Set_Expanded_Name,
Set_Interface_Table => RE_Set_Interface_Table, Set_External_Tag => RE_Set_External_Tag,
Set_Offset_Index => RE_Set_Offset_Index, Set_Interface_Table => RE_Set_Interface_Table,
Set_OSD => RE_Set_OSD, Set_Offset_Index => RE_Set_Offset_Index,
Set_Prim_Op_Address => RE_Set_Prim_Op_Address, Set_OSD => RE_Set_OSD,
Set_Prim_Op_Kind => RE_Set_Prim_Op_Kind, Set_Predefined_Prim_Op_Address => RE_Set_Predefined_Prim_Op_Address,
Set_RC_Offset => RE_Set_RC_Offset, Set_Prim_Op_Address => RE_Set_Prim_Op_Address,
Set_Remotely_Callable => RE_Set_Remotely_Callable, Set_Prim_Op_Kind => RE_Set_Prim_Op_Kind,
Set_SSD => RE_Set_SSD, Set_RC_Offset => RE_Set_RC_Offset,
Set_TSD => RE_Set_TSD, Set_Remotely_Callable => RE_Set_Remotely_Callable,
Set_Tagged_Kind => RE_Set_Tagged_Kind, Set_Signature => RE_Set_Signature,
TSD_Entry_Size => RE_TSD_Entry_Size, Set_SSD => RE_Set_SSD,
TSD_Prologue_Size => RE_TSD_Prologue_Size); 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 := Action_Is_Proc : constant array (DT_Access_Action) of Boolean :=
(CW_Membership => False, (CW_Membership => False,
IW_Membership => False, IW_Membership => False,
DT_Entry_Size => False, DT_Entry_Size => False,
DT_Prologue_Size => False, DT_Prologue_Size => False,
Get_Access_Level => False, Get_Access_Level => False,
Get_Entry_Index => False, Get_Entry_Index => False,
Get_External_Tag => False, Get_External_Tag => False,
Get_Prim_Op_Address => False, Get_Predefined_Prim_Op_Address => False,
Get_Prim_Op_Kind => False, Get_Prim_Op_Address => False,
Get_RC_Offset => False, Get_Prim_Op_Kind => False,
Get_Remotely_Callable => False, Get_RC_Offset => False,
Get_Tagged_Kind => False, Get_Remotely_Callable => False,
Inherit_DT => True, Get_Tagged_Kind => False,
Inherit_TSD => True, Inherit_DT => True,
Register_Interface_Tag => True, Inherit_TSD => True,
Register_Tag => True, Register_Interface_Tag => True,
Set_Access_Level => True, Register_Tag => True,
Set_Entry_Index => True, Set_Access_Level => True,
Set_Expanded_Name => True, Set_Entry_Index => True,
Set_External_Tag => True, Set_Expanded_Name => True,
Set_Interface_Table => True, Set_External_Tag => True,
Set_Offset_Index => True, Set_Interface_Table => True,
Set_OSD => True, Set_Offset_Index => True,
Set_Prim_Op_Address => True, Set_OSD => True,
Set_Prim_Op_Kind => True, Set_Predefined_Prim_Op_Address => True,
Set_RC_Offset => True, Set_Prim_Op_Address => True,
Set_Remotely_Callable => True, Set_Prim_Op_Kind => True,
Set_SSD => True, Set_RC_Offset => True,
Set_TSD => True, Set_Remotely_Callable => True,
Set_Tagged_Kind => True, Set_Signature => True,
TSD_Entry_Size => False, Set_SSD => True,
TSD_Prologue_Size => False); 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 := Action_Nb_Arg : constant array (DT_Access_Action) of Int :=
(CW_Membership => 2, (CW_Membership => 2,
IW_Membership => 2, IW_Membership => 2,
DT_Entry_Size => 0, DT_Entry_Size => 0,
DT_Prologue_Size => 0, DT_Prologue_Size => 0,
Get_Access_Level => 1, Get_Access_Level => 1,
Get_Entry_Index => 2, Get_Entry_Index => 2,
Get_External_Tag => 1, Get_External_Tag => 1,
Get_Prim_Op_Address => 2, Get_Predefined_Prim_Op_Address => 2,
Get_Prim_Op_Kind => 2, Get_Prim_Op_Address => 2,
Get_RC_Offset => 1, Get_Prim_Op_Kind => 2,
Get_Remotely_Callable => 1, Get_RC_Offset => 1,
Get_Tagged_Kind => 1, Get_Remotely_Callable => 1,
Inherit_DT => 3, Get_Tagged_Kind => 1,
Inherit_TSD => 2, Inherit_DT => 3,
Register_Interface_Tag => 3, Inherit_TSD => 2,
Register_Tag => 1, Register_Interface_Tag => 3,
Set_Access_Level => 2, Register_Tag => 1,
Set_Entry_Index => 3, Set_Access_Level => 2,
Set_Expanded_Name => 2, Set_Entry_Index => 3,
Set_External_Tag => 2, Set_Expanded_Name => 2,
Set_Interface_Table => 2, Set_External_Tag => 2,
Set_Offset_Index => 3, Set_Interface_Table => 2,
Set_OSD => 2, Set_Offset_Index => 3,
Set_Prim_Op_Address => 3, Set_OSD => 2,
Set_Prim_Op_Kind => 3, Set_Predefined_Prim_Op_Address => 3,
Set_RC_Offset => 2, Set_Prim_Op_Address => 3,
Set_Remotely_Callable => 2, Set_Prim_Op_Kind => 3,
Set_SSD => 2, Set_RC_Offset => 2,
Set_TSD => 2, Set_Remotely_Callable => 2,
Set_Tagged_Kind => 2, Set_Signature => 2,
TSD_Entry_Size => 0, Set_SSD => 2,
TSD_Prologue_Size => 0); Set_TSD => 2,
Set_Tagged_Kind => 2,
TSD_Entry_Size => 0,
TSD_Prologue_Size => 0);
procedure Collect_All_Interfaces (T : Entity_Id); procedure Collect_All_Interfaces (T : Entity_Id);
-- Ada 2005 (AI-251): Collect the whole list of interfaces that are -- Ada 2005 (AI-251): Collect the whole list of interfaces that are
-- directly or indirectly implemented by T. Used to compute the size -- directly or indirectly implemented by T. Used to compute the size
-- of the table of interfaces. -- 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 -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
-- of the default primitive operations. -- of the default primitive operations.
...@@ -453,7 +464,7 @@ package body Exp_Disp is ...@@ -453,7 +464,7 @@ package body Exp_Disp is
Next_Elmt (Elmt); Next_Elmt (Elmt);
end loop; end loop;
if not Present (Elmt) then if No (Elmt) then
Append_Elmt (Iface, Abstract_Interfaces (T)); Append_Elmt (Iface, Abstract_Interfaces (T));
end if; end if;
end Add_Interface; end Add_Interface;
...@@ -520,17 +531,10 @@ package body Exp_Disp is ...@@ -520,17 +531,10 @@ package body Exp_Disp is
-- Default_Prim_Op_Position -- -- 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; TSS_Name : TSS_Name_Type;
E : Entity_Id := Subp;
begin begin
-- Handle overriden subprograms
while Present (Alias (E)) loop
E := Alias (E);
end loop;
Get_Name_String (Chars (E)); Get_Name_String (Chars (E));
TSS_Name := TSS_Name :=
TSS_Name_Type TSS_Name_Type
...@@ -672,6 +676,8 @@ package body Exp_Disp is ...@@ -672,6 +676,8 @@ package body Exp_Disp is
-- Start of processing for Expand_Dispatching_Call -- Start of processing for Expand_Dispatching_Call
begin begin
Check_Restriction (No_Dispatching_Calls, Call_Node);
-- If this is an inherited operation that was overridden, the body -- If this is an inherited operation that was overridden, the body
-- that is being called is its alias. -- that is being called is its alias.
...@@ -702,7 +708,8 @@ package body Exp_Disp is ...@@ -702,7 +708,8 @@ package body Exp_Disp is
-- implementation of AI-260 (for the generic dispatching constructors). -- implementation of AI-260 (for the generic dispatching constructors).
if Etype (Ctrl_Arg) = RTE (RE_Tag) 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 then
CW_Typ := Class_Wide_Type (Controlling_Type (Subp)); CW_Typ := Class_Wide_Type (Controlling_Type (Subp));
...@@ -739,7 +746,6 @@ package body Exp_Disp is ...@@ -739,7 +746,6 @@ package body Exp_Disp is
-- Generate the Tag checks when appropriate -- Generate the Tag checks when appropriate
New_Params := New_List; New_Params := New_List;
Param := First_Actual (Call_Node); Param := First_Actual (Call_Node);
while Present (Param) loop while Present (Param) loop
...@@ -825,7 +831,7 @@ package body Exp_Disp is ...@@ -825,7 +831,7 @@ package body Exp_Disp is
-- Generate the appropriate subprogram pointer type -- Generate the appropriate subprogram pointer type
if Etype (Subp) = Typ then if Etype (Subp) = Typ then
Res_Typ := CW_Typ; Res_Typ := CW_Typ;
else else
Res_Typ := Etype (Subp); Res_Typ := Etype (Subp);
...@@ -909,12 +915,20 @@ package body Exp_Disp is ...@@ -909,12 +915,20 @@ package body Exp_Disp is
Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ); Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
-- If the controlling argument is a value of type Ada.Tag then -- If the controlling argument is a value of type Ada.Tag or an abstract
-- use it directly. Otherwise, the tag must be extracted from -- interface class-wide type then use it directly. Otherwise, the tag
-- the controlling object. -- must be extracted from the controlling object.
if Etype (Ctrl_Arg) = RTE (RE_Tag) 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 then
Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
...@@ -928,19 +942,38 @@ package body Exp_Disp is ...@@ -928,19 +942,38 @@ package body Exp_Disp is
-- Generate: -- Generate:
-- Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos)); -- Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos));
New_Call_Name := if Is_Predefined_Dispatching_Operation (Subp) then
Unchecked_Convert_To (Subp_Ptr_Typ, New_Call_Name :=
Make_DT_Access_Action (Typ, Unchecked_Convert_To (Subp_Ptr_Typ,
Action => Get_Prim_Op_Address, Make_DT_Access_Action (Typ,
Args => New_List ( 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 if Nkind (Call_Node) = N_Function_Call then
...@@ -1060,6 +1093,14 @@ package body Exp_Disp is ...@@ -1060,6 +1093,14 @@ package body Exp_Disp is
and then Is_Interface (Iface_Typ)); and then Is_Interface (Iface_Typ));
if not Is_Static then 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, Rewrite (N,
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Displace), Loc), Name => New_Reference_To (RTE (RE_Displace), Loc),
...@@ -1086,8 +1127,10 @@ package body Exp_Disp is ...@@ -1086,8 +1127,10 @@ package body Exp_Disp is
Set_Directly_Designated_Type (New_Itype, Set_Directly_Designated_Type (New_Itype,
Class_Wide_Type (Iface_Typ)); Class_Wide_Type (Iface_Typ));
Rewrite (N, Unchecked_Convert_To (New_Itype, Rewrite (N, Make_Explicit_Dereference (Loc,
Relocate_Node (N))); Unchecked_Convert_To (New_Itype,
Relocate_Node (N))));
Analyze (N);
end; end;
return; return;
...@@ -1166,7 +1209,7 @@ package body Exp_Disp is ...@@ -1166,7 +1209,7 @@ package body Exp_Disp is
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Relocate_Node (Expression (N)), Prefix => Make_Identifier (Loc, Name_uO),
Selector_Name => Selector_Name =>
New_Occurrence_Of (Iface_Tag, Loc)), New_Occurrence_Of (Iface_Tag, Loc)),
Attribute_Name => Name_Address)))))))); Attribute_Name => Name_Address))))))));
...@@ -1455,6 +1498,13 @@ package body Exp_Disp is ...@@ -1455,6 +1498,13 @@ package body Exp_Disp is
Next_Formal (E); Next_Formal (E);
end loop; 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 if Ekind (First_Formal (Target)) = E_In_Parameter
and then Ekind (Etype (First_Formal (Target))) and then Ekind (Etype (First_Formal (Target)))
= E_Anonymous_Access_Type = E_Anonymous_Access_Type
...@@ -1501,12 +1551,10 @@ package body Exp_Disp is ...@@ -1501,12 +1551,10 @@ package body Exp_Disp is
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
Parameter_Associations => New_List ( Parameter_Associations => New_List (
Make_Selected_Component (Loc, Unchecked_Convert_To
Prefix => New_Reference_To (RTE (RE_Address),
(Defining_Identifier (First (Formals)), New_Reference_To
Loc), (Defining_Identifier (First (Formals)), Loc))))));
Selector_Name => Make_Identifier (Loc,
Name_uTag))))));
Append_To (Decl, Decl_2); Append_To (Decl, Decl_2);
Append_To (Decl, Decl_1); Append_To (Decl, Decl_1);
...@@ -1546,12 +1594,11 @@ package body Exp_Disp is ...@@ -1546,12 +1594,11 @@ package body Exp_Disp is
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
Parameter_Associations => New_List ( Parameter_Associations => New_List (
Make_Selected_Component (Loc, Make_Attribute_Reference (Loc,
Prefix => New_Reference_To Prefix => New_Reference_To
(Defining_Identifier (First (Formals)), (Defining_Identifier (First (Formals)),
Loc), Loc),
Selector_Name => Make_Identifier (Loc, Attribute_Name => Name_Address)))));
Name_uTag))))));
Decl_2 := Decl_2 :=
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
...@@ -1637,22 +1684,37 @@ package body Exp_Disp is ...@@ -1637,22 +1684,37 @@ package body Exp_Disp is
Tag : constant Entity_Id := First_Tag_Component (Typ); Tag : constant Entity_Id := First_Tag_Component (Typ);
begin begin
if Pos = Uint_0 or else Pos > DT_Entry_Count (Tag) then pragma Assert (not Restriction_Active (No_Dispatching_Calls));
raise Program_Error;
end if;
return if Is_Predefined_Dispatching_Operation (Prim) then
Make_DT_Access_Action (Typ, return
Action => Set_Prim_Op_Address, Make_DT_Access_Action (Typ,
Args => New_List ( Action => Set_Predefined_Prim_Op_Address,
Unchecked_Convert_To (RTE (RE_Tag), Args => New_List (
New_Reference_To (DT_Ptr, Loc)), -- DTptr 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 Make_Attribute_Reference (Loc, -- Value
Prefix => New_Reference_To (Prim, Loc), Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Address))); Attribute_Name => Name_Address)));
end if;
end Fill_DT_Entry; end Fill_DT_Entry;
----------------------------- -----------------------------
...@@ -1672,22 +1734,35 @@ package body Exp_Disp is ...@@ -1672,22 +1734,35 @@ package body Exp_Disp is
First_Tag_Component (Scope (DTC_Entity (Iface_Prim))); First_Tag_Component (Scope (DTC_Entity (Iface_Prim)));
begin begin
if Pos = Uint_0 or else Pos > DT_Entry_Count (Tag) then if Is_Predefined_Dispatching_Operation (Prim) then
raise Program_Error; return
end if; 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_Integer_Literal (Loc, Pos), -- Position
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)));
else
pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
Make_Attribute_Reference (Loc, -- Value return
Prefix => New_Reference_To (Thunk_Id, Loc), Make_DT_Access_Action (Typ,
Attribute_Name => Name_Address))); 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; end Fill_Secondary_DT_Entry;
--------------------------- ---------------------------
...@@ -1723,7 +1798,10 @@ package body Exp_Disp is ...@@ -1723,7 +1798,10 @@ package body Exp_Disp is
-- No need to inherit primitives if we have an abstract interface -- No need to inherit primitives if we have an abstract interface
-- type or a concurrent type. -- 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; return Result;
end if; end if;
...@@ -1734,7 +1812,7 @@ package body Exp_Disp is ...@@ -1734,7 +1812,7 @@ package body Exp_Disp is
-- associated with predefined primitives. -- associated with predefined primitives.
-- Generate: -- Generate:
-- Inherit_DT (T'Tag, Iface'Tag, Default_Prim_Op_Count); -- Inherit_DT (T'Tag, Iface'Tag, 0);
Append_To (Result, Append_To (Result,
Make_DT_Access_Action (Typ, Make_DT_Access_Action (Typ,
...@@ -1743,7 +1821,7 @@ package body Exp_Disp is ...@@ -1743,7 +1821,7 @@ package body Exp_Disp is
Node1 => New_Reference_To (DT_Ptr, Loc), Node1 => New_Reference_To (DT_Ptr, Loc),
Node2 => Unchecked_Convert_To (RTE (RE_Tag), Node2 => Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Node (AI), Loc)), 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); Next_Elmt (AI);
end loop; end loop;
...@@ -1765,6 +1843,8 @@ package body Exp_Disp is ...@@ -1765,6 +1843,8 @@ package body Exp_Disp is
Stmts : constant List_Id := New_List; Stmts : constant List_Id := New_List;
begin begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
-- Null body is generated for interface types -- Null body is generated for interface types
if Is_Interface (Typ) then if Is_Interface (Typ) then
...@@ -1911,6 +1991,8 @@ package body Exp_Disp is ...@@ -1911,6 +1991,8 @@ package body Exp_Disp is
Params : constant List_Id := New_List; Params : constant List_Id := New_List;
begin begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
-- "T" - Object parameter -- "T" - Object parameter
-- "S" - Primitive operation slot -- "S" - Primitive operation slot
-- "P" - Wrapped parameters -- "P" - Wrapped parameters
...@@ -1946,6 +2028,8 @@ package body Exp_Disp is ...@@ -1946,6 +2028,8 @@ package body Exp_Disp is
Stmts : constant List_Id := New_List; Stmts : constant List_Id := New_List;
begin begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
-- Null body is generated for interface types -- Null body is generated for interface types
if Is_Interface (Typ) then if Is_Interface (Typ) then
...@@ -2152,6 +2236,8 @@ package body Exp_Disp is ...@@ -2152,6 +2236,8 @@ package body Exp_Disp is
Params : constant List_Id := New_List; Params : constant List_Id := New_List;
begin begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
-- "T" - Object parameter -- "T" - Object parameter
-- "S" - Primitive operation slot -- "S" - Primitive operation slot
-- "P" - Wrapped parameters -- "P" - Wrapped parameters
...@@ -2183,6 +2269,8 @@ package body Exp_Disp is ...@@ -2183,6 +2269,8 @@ package body Exp_Disp is
DT_Ptr : Entity_Id; DT_Ptr : Entity_Id;
begin begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
if Is_Interface (Typ) then if Is_Interface (Typ) then
return return
Make_Subprogram_Body (Loc, Make_Subprogram_Body (Loc,
...@@ -2240,6 +2328,8 @@ package body Exp_Disp is ...@@ -2240,6 +2328,8 @@ package body Exp_Disp is
Params : constant List_Id := New_List; Params : constant List_Id := New_List;
begin begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
-- "T" - Object parameter -- "T" - Object parameter
-- "S" - Primitive operation slot -- "S" - Primitive operation slot
-- "C" - Call kind -- "C" - Call kind
...@@ -2267,6 +2357,8 @@ package body Exp_Disp is ...@@ -2267,6 +2357,8 @@ package body Exp_Disp is
Ret : Node_Id; Ret : Node_Id;
begin begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
if Is_Concurrent_Record_Type (Typ) if Is_Concurrent_Record_Type (Typ)
and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type
then then
...@@ -2312,6 +2404,8 @@ package body Exp_Disp is ...@@ -2312,6 +2404,8 @@ package body Exp_Disp is
Name_uDisp_Get_Task_Id); Name_uDisp_Get_Task_Id);
begin begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
Set_Is_Internal (Def_Id); Set_Is_Internal (Def_Id);
return return
...@@ -2341,6 +2435,8 @@ package body Exp_Disp is ...@@ -2341,6 +2435,8 @@ package body Exp_Disp is
Stmts : constant List_Id := New_List; Stmts : constant List_Id := New_List;
begin begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
-- Null body is generated for interface types -- Null body is generated for interface types
if Is_Interface (Typ) then if Is_Interface (Typ) then
...@@ -2515,6 +2611,8 @@ package body Exp_Disp is ...@@ -2515,6 +2611,8 @@ package body Exp_Disp is
Params : constant List_Id := New_List; Params : constant List_Id := New_List;
begin begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
-- "T" - Object parameter -- "T" - Object parameter
-- "S" - Primitive operation slot -- "S" - Primitive operation slot
-- "P" - Wrapped parameters -- "P" - Wrapped parameters
...@@ -2590,6 +2688,7 @@ package body Exp_Disp is ...@@ -2590,6 +2688,7 @@ package body Exp_Disp is
TSD_Num_Entries : Int; TSD_Num_Entries : Int;
Ancestor_Copy : Entity_Id; Ancestor_Copy : Entity_Id;
Empty_DT : Boolean := False;
Typ_Copy : Entity_Id; Typ_Copy : Entity_Id;
begin begin
...@@ -2601,11 +2700,13 @@ package body Exp_Disp is ...@@ -2601,11 +2700,13 @@ package body Exp_Disp is
-- Calculate the size of the DT and the TSD -- Calculate the size of the DT and the TSD
if Is_Interface (Typ) then if Is_Interface (Typ) then
-- Abstract interfaces need neither the DT nor the ancestors table. -- Abstract interfaces need neither the DT nor the ancestors table.
-- We reserve a single entry for its DT because at run-time the -- 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 -- pointer to this dummy DT will be used as the tag of this abstract
-- interface type. -- interface type.
Empty_DT := True;
Nb_Prim := 1; Nb_Prim := 1;
TSD_Num_Entries := 0; TSD_Num_Entries := 0;
Num_Ifaces := 0; Num_Ifaces := 0;
...@@ -2669,12 +2770,14 @@ package body Exp_Disp is ...@@ -2669,12 +2770,14 @@ package body Exp_Disp is
TSD_Num_Entries := I_Depth + 1; TSD_Num_Entries := I_Depth + 1;
Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); 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 -- If the number of primitives of Typ is 0 (or we are compiling with
-- predefined primitives, we must reserve at least enough space -- the No_Dispatching_Calls restriction) we reserve a dummy single
-- for the predefined primitives. -- 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 if Nb_Prim = 0 or else Restriction_Active (No_Dispatching_Calls) then
Nb_Prim := Default_Prim_Op_Count; Empty_DT := True;
Nb_Prim := 1;
end if; end if;
end if; end if;
...@@ -2746,52 +2849,6 @@ package body Exp_Disp is ...@@ -2746,52 +2849,6 @@ package body Exp_Disp is
Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment))); 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 -- Generate code to create the pointer to the dispatch table
-- DT_Ptr : Tag := Tag!(DT'Address); -- DT_Ptr : Tag := Tag!(DT'Address);
...@@ -2829,7 +2886,7 @@ package body Exp_Disp is ...@@ -2829,7 +2886,7 @@ package body Exp_Disp is
-- Set Access_Disp_Table field to be the dispatch table pointer -- 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); Set_Access_Disp_Table (Typ, New_Elmt_List);
end if; end if;
...@@ -2876,6 +2933,26 @@ package body Exp_Disp is ...@@ -2876,6 +2933,26 @@ package body Exp_Disp is
Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment))); 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 -- Generate code to put the Address of the TSD in the dispatch table
-- Set_TSD (DT_Ptr, TSD); -- Set_TSD (DT_Ptr, TSD);
...@@ -2895,17 +2972,19 @@ package body Exp_Disp is ...@@ -2895,17 +2972,19 @@ package body Exp_Disp is
null; null;
elsif Num_Ifaces = 0 then elsif Num_Ifaces = 0 then
Append_To (Elab_Code, if RTE_Available (RE_Set_Interface_Table) then
Make_DT_Access_Action (Typ, Append_To (Elab_Code,
Action => Set_Interface_Table, Make_DT_Access_Action (Typ,
Args => New_List ( Action => Set_Interface_Table,
New_Reference_To (DT_Ptr, Loc), -- DTptr Args => New_List (
New_Reference_To (RTE (RE_Null_Address), Loc)))); -- null 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 -- Generate the Interface_Table object and set the access
-- component if the TSD to it. -- component if the TSD to it.
else elsif RTE_Available (RE_Set_Interface_Table) then
Append_To (Result, Append_To (Result,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => ITable, Defining_Identifier => ITable,
...@@ -2932,65 +3011,77 @@ package body Exp_Disp is ...@@ -2932,65 +3011,77 @@ package body Exp_Disp is
-- Generate: -- Generate:
-- Set_Num_Prim_Ops (T'Tag, Nb_Prim) -- Set_Num_Prim_Ops (T'Tag, Nb_Prim)
if not Is_Interface (Typ) then if RTE_Available (RE_Set_Num_Prim_Ops) then
Append_To (Elab_Code, if not Is_Interface (Typ) then
Make_Procedure_Call_Statement (Loc, if Empty_DT then
Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc), Append_To (Elab_Code,
Parameter_Associations => New_List ( Make_Procedure_Call_Statement (Loc,
New_Reference_To (DT_Ptr, Loc), Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc),
Make_Integer_Literal (Loc, Nb_Prim)))); Parameter_Associations => New_List (
end if; New_Reference_To (DT_Ptr, Loc),
Make_Integer_Literal (Loc, Uint_0))));
if Ada_Version >= Ada_05 else
and then not Is_Interface (Typ) Append_To (Elab_Code,
and then not Is_Abstract (Typ) Make_Procedure_Call_Statement (Loc,
and then not Is_Controlled (Typ) Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc),
then Parameter_Associations => New_List (
-- Generate: New_Reference_To (DT_Ptr, Loc),
-- Set_Type_Kind (T'Tag, Type_Kind (Typ)); Make_Integer_Literal (Loc, Nb_Prim))));
end if;
Append_To (Elab_Code, end if;
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 Is_Concurrent_Record_Type (Typ) if Ada_Version >= Ada_05
and then Implements_Interface ( and then not Is_Interface (Typ)
Typ => Typ, and then not Is_Abstract (Typ)
Kind => Any_Limited_Interface, and then not Is_Controlled (Typ)
Check_Parent => True) and then not Restriction_Active (No_Dispatching_Calls)
and then (Nb_Prim - Default_Prim_Op_Count) > 0
then then
Append_To (Result, -- Generate:
Make_Object_Declaration (Loc, -- Set_Type_Kind (T'Tag, Type_Kind (Typ));
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
Append_To (Elab_Code, Append_To (Elab_Code,
Make_DT_Access_Action (Typ, Make_DT_Access_Action (Typ,
Action => Set_SSD, Action => Set_Tagged_Kind,
Args => New_List ( Args => New_List (
New_Reference_To (DT_Ptr, Loc), -- DTptr New_Reference_To (DT_Ptr, Loc), -- DTptr
Make_Attribute_Reference (Loc, -- Value Tagged_Kind (Typ)))); -- Value
Prefix => New_Reference_To (SSD, Loc),
Attribute_Name => Name_Address)))); -- 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;
end if; end if;
...@@ -3052,24 +3143,37 @@ package body Exp_Disp is ...@@ -3052,24 +3143,37 @@ package body Exp_Disp is
if Typ /= Etype (Typ) if Typ /= Etype (Typ)
and then not Is_Interface (Typ) and then not Is_Interface (Typ)
and then not Restriction_Active (No_Dispatching_Calls)
then then
-- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent); -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
if not Is_Interface (Etype (Typ)) then if not Is_Interface (Etype (Typ)) then
Append_To (Elab_Code, if Restriction_Active (No_Dispatching_Calls) then
Make_DT_Access_Action (Typ, Append_To (Elab_Code,
Action => Inherit_DT, Make_DT_Access_Action (Typ,
Args => New_List ( Action => Inherit_DT,
Node1 => Old_Tag1, Args => New_List (
Node2 => New_Reference_To (DT_Ptr, Loc), Node1 => Old_Tag1,
Node3 => Node2 => New_Reference_To (DT_Ptr, Loc),
Make_Integer_Literal (Loc, Node3 => Make_Integer_Literal (Loc, Uint_0))));
DT_Entry_Count (First_Tag_Component (Etype (Typ))))))); 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; end if;
-- Inherit the secondary dispatch tables of the ancestor -- 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 declare
Sec_DT_Ancestor : Elmt_Id := Sec_DT_Ancestor : Elmt_Id :=
Next_Elmt Next_Elmt
...@@ -3089,8 +3193,8 @@ package body Exp_Disp is ...@@ -3089,8 +3193,8 @@ package body Exp_Disp is
------------------------ ------------------------
procedure Copy_Secondary_DTs (Typ : Entity_Id) is procedure Copy_Secondary_DTs (Typ : Entity_Id) is
E : Entity_Id; E : Entity_Id;
Iface : Elmt_Id; Iface : Elmt_Id;
begin begin
-- Climb to the ancestor (if any) handling private types -- Climb to the ancestor (if any) handling private types
...@@ -3110,7 +3214,6 @@ package body Exp_Disp is ...@@ -3110,7 +3214,6 @@ package body Exp_Disp is
then then
Iface := First_Elmt (Abstract_Interfaces (Typ)); Iface := First_Elmt (Abstract_Interfaces (Typ));
E := First_Entity (Typ); E := First_Entity (Typ);
while Present (E) while Present (E)
and then Present (Node (Sec_DT_Ancestor)) and then Present (Node (Sec_DT_Ancestor))
loop loop
...@@ -3168,23 +3271,24 @@ package body Exp_Disp is ...@@ -3168,23 +3271,24 @@ package body Exp_Disp is
Node1 => Old_Tag2, Node1 => Old_Tag2,
Node2 => New_Reference_To (DT_Ptr, Loc)))); Node2 => New_Reference_To (DT_Ptr, Loc))));
-- For types with no controlled components, generate: if not Is_Interface (Typ) then
-- Set_RC_Offset (DT_Ptr, 0);
-- For simple types with controlled components, generate: -- For types with no controlled components, generate:
-- Set_RC_Offset (DT_Ptr, type._record_controller'position); -- Set_RC_Offset (DT_Ptr, 0);
-- For complex types with controlled components where the position -- For simple types with controlled components, generate:
-- of the record controller is not statically computable, if there are -- Set_RC_Offset (DT_Ptr, type._record_controller'position);
-- 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: -- For complex types with controlled components where the position
-- Set_RC_Offset (DT_Ptr, -2); -- of the record controller is not statically computable, if there
-- to indicate that we need to get the position from the parent. -- 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 declare
Position : Node_Id; Position : Node_Id;
...@@ -3258,16 +3362,20 @@ package body Exp_Disp is ...@@ -3258,16 +3362,20 @@ package body Exp_Disp is
New_Occurrence_Of (Status, Loc)))); New_Occurrence_Of (Status, Loc))));
end; end;
-- Generate: if RTE_Available (RE_Set_Offset_To_Top) then
-- Set_Offset_To_Top (0, DT_Ptr, 0); -- Generate:
-- Set_Offset_To_Top (0, DT_Ptr, True, 0, null);
Append_To (Elab_Code, Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc), Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
Parameter_Associations => New_List ( Parameter_Associations => New_List (
New_Reference_To (RTE (RE_Null_Address), Loc), New_Reference_To (RTE (RE_Null_Address), Loc),
New_Reference_To (DT_Ptr, Loc), New_Reference_To (DT_Ptr, Loc),
Make_Integer_Literal (Loc, Uint_0)))); New_Occurrence_Of (Standard_True, Loc),
Make_Integer_Literal (Loc, Uint_0),
New_Reference_To (RTE (RE_Null_Address), Loc))));
end if;
end if; end if;
-- Generate: Set_External_Tag (DT_Ptr, exname'Address); -- Generate: Set_External_Tag (DT_Ptr, exname'Address);
...@@ -3284,15 +3392,15 @@ package body Exp_Disp is ...@@ -3284,15 +3392,15 @@ package body Exp_Disp is
Prefix => New_Reference_To (Exname, Loc), Prefix => New_Reference_To (Exname, Loc),
Attribute_Name => Name_Address)))); Attribute_Name => Name_Address))));
-- Generate code to register the Tag in the External_Tag hash -- Generate code to register the Tag in the External_Tag hash
-- table for the pure Ada type only. -- 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 -- Skip this if routine not available, or in No_Run_Time mode
-- or Typ is an abstract interface type (because the table to -- or Typ is an abstract interface type (because the table to
-- register it is not available in the abstract type but in -- register it is not available in the abstract type but in
-- types implementing this interface) -- types implementing this interface)
if not No_Run_Time_Mode if not No_Run_Time_Mode
and then RTE_Available (RE_Register_Tag) and then RTE_Available (RE_Register_Tag)
...@@ -3459,6 +3567,7 @@ package body Exp_Disp is ...@@ -3459,6 +3567,7 @@ package body Exp_Disp is
Loc : constant Source_Ptr := Sloc (AI_Tag); Loc : constant Source_Ptr := Sloc (AI_Tag);
Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag); Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag);
Name_DT : constant Name_Id := New_Internal_Name ('T'); Name_DT : constant Name_Id := New_Internal_Name ('T');
Empty_DT : Boolean := False;
Iface_DT : Node_Id; Iface_DT : Node_Id;
Iface_DT_Ptr : Node_Id; Iface_DT_Ptr : Node_Id;
Name_DT_Ptr : Name_Id; Name_DT_Ptr : Name_Id;
...@@ -3493,14 +3602,15 @@ package body Exp_Disp is ...@@ -3493,14 +3602,15 @@ package body Exp_Disp is
Set_Is_Statically_Allocated (Iface_DT_Ptr); Set_Is_Statically_Allocated (Iface_DT_Ptr);
-- Generate code to create the storage for the Dispatch_Table object. -- Generate code to create the storage for the Dispatch_Table object.
-- If the number of primitives of Typ is less that the number of -- If the number of primitives of Typ is 0 we reserve a dummy single
-- predefined primitives, we must reserve at least enough space -- entry for its DT because at run-time the pointer to this dummy entry
-- for the predefined primitives. -- will be used as the tag.
Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag)); Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag));
if Nb_Prim < Default_Prim_Op_Count then if Nb_Prim = 0 then
Nb_Prim := Default_Prim_Op_Count; Empty_DT := True;
Nb_Prim := 1;
end if; end if;
-- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size); -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
...@@ -3542,32 +3652,6 @@ package body Exp_Disp is ...@@ -3542,32 +3652,6 @@ package body Exp_Disp is
Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment))); 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 -- Generate code to create the pointer to the dispatch table
-- Iface_DT_Ptr : Tag := Tag!(DT'Address); -- Iface_DT_Ptr : Tag := Tag!(DT'Address);
...@@ -3607,9 +3691,16 @@ package body Exp_Disp is ...@@ -3607,9 +3691,16 @@ package body Exp_Disp is
OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); 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: -- Generate:
-- OSD : Ada.Tags.Object_Specific_Data -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims);
-- (Nb_Prims - Default_Prim_Op_Count);
-- where the constraint is used to allocate space for the -- where the constraint is used to allocate space for the
-- non-predefined primitive operations only. -- non-predefined primitive operations only.
...@@ -3623,8 +3714,15 @@ package body Exp_Disp is ...@@ -3623,8 +3714,15 @@ package body Exp_Disp is
Constraint => Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc, Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List ( Constraints => New_List (
Make_Integer_Literal (Loc, Make_Integer_Literal (Loc, Nb_Prim))))));
Nb_Prim - Default_Prim_Op_Count + 1))))));
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: -- Generate:
-- Ada.Tags.Set_OSD (Iface_DT_Ptr, OSD); -- Ada.Tags.Set_OSD (Iface_DT_Ptr, OSD);
...@@ -3642,18 +3740,32 @@ package body Exp_Disp is ...@@ -3642,18 +3740,32 @@ package body Exp_Disp is
-- Generate: -- Generate:
-- Set_Num_Prim_Ops (T'Tag, Nb_Prim) -- Set_Num_Prim_Ops (T'Tag, Nb_Prim)
Append_To (Result, if RTE_Available (RE_Set_Num_Prim_Ops) then
Make_Procedure_Call_Statement (Loc, if Empty_DT then
Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc), Append_To (Result,
Parameter_Associations => New_List ( Make_Procedure_Call_Statement (Loc,
Unchecked_Convert_To (RTE (RE_Tag), Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc),
New_Reference_To (Iface_DT_Ptr, Loc)), Parameter_Associations => New_List (
Make_Integer_Literal (Loc, Nb_Prim)))); 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 if Ada_Version >= Ada_05
and then not Is_Interface (Typ) and then not Is_Interface (Typ)
and then not Is_Abstract (Typ) and then not Is_Abstract (Typ)
and then not Is_Controlled (Typ) and then not Is_Controlled (Typ)
and then RTE_Available (RE_Set_Tagged_Kind)
and then not Restriction_Active (No_Dispatching_Calls)
then then
-- Generate: -- Generate:
-- Set_Tagged_Kind (Iface'Tag, Tagged_Kind (Iface)); -- Set_Tagged_Kind (Iface'Tag, Tagged_Kind (Iface));
...@@ -3666,12 +3778,12 @@ package body Exp_Disp is ...@@ -3666,12 +3778,12 @@ package body Exp_Disp is
New_Reference_To (Iface_DT_Ptr, Loc)), New_Reference_To (Iface_DT_Ptr, Loc)),
Tagged_Kind (Typ)))); -- Value 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 ( and then Implements_Interface (
Typ => Typ, Typ => Typ,
Kind => Any_Limited_Interface, Kind => Any_Limited_Interface,
Check_Parent => True) Check_Parent => True)
and then (Nb_Prim - Default_Prim_Op_Count) > 0
then then
declare declare
Prim : Entity_Id; Prim : Entity_Id;
...@@ -3729,14 +3841,14 @@ package body Exp_Disp is ...@@ -3729,14 +3841,14 @@ package body Exp_Disp is
Assignments : constant List_Id := New_List; Assignments : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (Typ); Loc : constant Source_Ptr := Sloc (Typ);
Conc_Typ : Entity_Id; Conc_Typ : Entity_Id;
Decls : List_Id; Decls : List_Id;
DT_Ptr : Entity_Id; DT_Ptr : Entity_Id;
Prim : Entity_Id; Prim : Entity_Id;
Prim_Als : Entity_Id; Prim_Als : Entity_Id;
Prim_Elmt : Elmt_Id; Prim_Elmt : Elmt_Id;
Prim_Pos : Uint; Prim_Pos : Uint;
Nb_Prim : Int := 0; Nb_Prim : Int := 0;
type Examined_Array is array (Int range <>) of Boolean; type Examined_Array is array (Int range <>) of Boolean;
...@@ -3776,6 +3888,8 @@ package body Exp_Disp is ...@@ -3776,6 +3888,8 @@ package body Exp_Disp is
-- Start of processing for Make_Select_Specific_Data_Table -- Start of processing for Make_Select_Specific_Data_Table
begin begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
if Present (Corresponding_Concurrent_Type (Typ)) then if Present (Corresponding_Concurrent_Type (Typ)) then
...@@ -3803,8 +3917,7 @@ package body Exp_Disp is ...@@ -3803,8 +3917,7 @@ package body Exp_Disp is
end loop; end loop;
declare declare
Examined_Size : constant Int := Nb_Prim + Default_Prim_Op_Count; Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
Examined : Examined_Array (1 .. Examined_Size) := (others => False);
begin begin
Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
...@@ -3812,64 +3925,69 @@ package body Exp_Disp is ...@@ -3812,64 +3925,69 @@ package body Exp_Disp is
Prim := Node (Prim_Elmt); Prim := Node (Prim_Elmt);
Prim_Pos := DT_Position (Prim); Prim_Pos := DT_Position (Prim);
pragma Assert (UI_To_Int (Prim_Pos) <= Examined_Size); 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, if Examined (UI_To_Int (Prim_Pos)) then
Make_DT_Access_Action (Typ, goto Continue;
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 else
Prim_Als := Empty; Examined (UI_To_Int (Prim_Pos)) := True;
end if; 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 if Present (Abstract_Interface_Alias (Prim)) then
and then Present (Prim_Als)
and then Is_Primitive_Wrapper (Prim_Als)
and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
then
-- Generate: -- Set the primitive operation kind regardless of subprogram
-- Ada.Tags.Set_Entry_Index (DT_Ptr, <position>, <index>); -- type. Generate:
-- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
Append_To (Assignments, Append_To (Assignments,
Make_DT_Access_Action (Typ, Make_DT_Access_Action (Typ,
Action => Action =>
Set_Entry_Index, Set_Prim_Op_Kind,
Args => Args =>
New_List ( New_List (
New_Reference_To (DT_Ptr, Loc), New_Reference_To (DT_Ptr, Loc),
Make_Integer_Literal (Loc, Prim_Pos), Make_Integer_Literal (Loc, Prim_Pos),
Make_Integer_Literal (Loc, Prim_Op_Kind (Prim, Typ))));
Find_Entry_Index (Wrapped_Entity (Prim_Als))))));
-- 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;
end if; end if;
...@@ -3919,11 +4037,12 @@ package body Exp_Disp is ...@@ -3919,11 +4037,12 @@ package body Exp_Disp is
is is
Full_Typ : Entity_Id := Typ; Full_Typ : Entity_Id := Typ;
Loc : constant Source_Ptr := Sloc (Prim); Loc : constant Source_Ptr := Sloc (Prim);
Prim_Op : Entity_Id := Prim; Prim_Op : Entity_Id;
begin begin
-- Retrieve the original primitive operation -- Retrieve the original primitive operation
Prim_Op := Prim;
while Present (Alias (Prim_Op)) loop while Present (Alias (Prim_Op)) loop
Prim_Op := Alias (Prim_Op); Prim_Op := Alias (Prim_Op);
end loop; end loop;
...@@ -4037,8 +4156,8 @@ package body Exp_Disp is ...@@ -4037,8 +4156,8 @@ package body Exp_Disp is
if Present (Abstract_Interface_Alias (Node (Prim_Elmt))) then if Present (Abstract_Interface_Alias (Node (Prim_Elmt))) then
null; null;
-- Predefined dispatching operations are completely safe. -- Predefined dispatching operations are completely safe. They
-- They are allocated at fixed positions. -- are allocated at fixed positions in a separate table.
elsif Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then elsif Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then
null; null;
...@@ -4266,8 +4385,7 @@ package body Exp_Disp is ...@@ -4266,8 +4385,7 @@ package body Exp_Disp is
end loop; end loop;
declare declare
Fixed_Prim : array (Int range 0 .. Default_Prim_Op_Count + Fixed_Prim : array (Int range 0 .. Parent_EC + Count_Prim)
Parent_EC + Count_Prim)
of Boolean := (others => False); of Boolean := (others => False);
E : Entity_Id; E : Entity_Id;
...@@ -4275,17 +4393,16 @@ package body Exp_Disp is ...@@ -4275,17 +4393,16 @@ package body Exp_Disp is
begin begin
-- Second stage: Register fixed entries -- Second stage: Register fixed entries
Nb_Prim := Default_Prim_Op_Count; Nb_Prim := 0;
Prim_Elmt := First_Prim; Prim_Elmt := First_Prim;
while Present (Prim_Elmt) loop while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt); Prim := Node (Prim_Elmt);
-- Predefined primitives have a fixed position in all the -- Predefined primitives have a separate table and all its
-- dispatch tables -- entries are at predefined fixed positions
if Is_Predefined_Dispatching_Operation (Prim) then if Is_Predefined_Dispatching_Operation (Prim) then
Set_DT_Position (Prim, Default_Prim_Op_Position (Prim)); Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True;
-- Overriding interface primitives of an ancestor -- Overriding interface primitives of an ancestor
...@@ -4355,7 +4472,10 @@ package body Exp_Disp is ...@@ -4355,7 +4472,10 @@ package body Exp_Disp is
-- Skip primitives previously set entries -- 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; null;
elsif Etype (DTC_Entity (Prim)) /= RTE (RE_Tag) then elsif Etype (DTC_Entity (Prim)) /= RTE (RE_Tag) then
...@@ -4442,14 +4562,18 @@ package body Exp_Disp is ...@@ -4442,14 +4562,18 @@ package body Exp_Disp is
-- Calculate real size of the dispatch table -- 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)); DT_Length := UI_To_Int (DT_Position (Prim));
end if; end if;
-- Ensure that the asignated position in the dispatch -- Ensure that the asignated position to non-predefined
-- table is correct -- 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 if Chars (Prim) = Name_Finalize then
Finalized := True; Finalized := True;
...@@ -4591,7 +4715,8 @@ package body Exp_Disp is ...@@ -4591,7 +4715,8 @@ package body Exp_Disp is
Loc : constant Source_Ptr := Sloc (T); Loc : constant Source_Ptr := Sloc (T);
begin begin
pragma Assert (Is_Tagged_Type (T)); pragma Assert
(Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));
-- Abstract kinds -- Abstract kinds
...@@ -4676,6 +4801,11 @@ package body Exp_Disp is ...@@ -4676,6 +4801,11 @@ package body Exp_Disp is
Write_Int (Int (Prim)); Write_Int (Int (Prim));
Write_Str (": "); Write_Str (": ");
if Is_Predefined_Dispatching_Operation (Prim) then
Write_Str ("(predefined) ");
end if;
Write_Name (Chars (Prim)); Write_Name (Chars (Prim));
-- Indicate if this primitive has an aliased primitive -- Indicate if this primitive has an aliased primitive
......
gcc/ada/exp_disp.ads
...@@ -136,12 +136,8 @@ package Exp_Disp is ...@@ -136,12 +136,8 @@ package Exp_Disp is
-- Guidelines for addition of new predefined primitive operations -- 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 -- 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 -- to reflect the new number of PPOs.
-- as the one in Exp_Disp.ads.
-- Introduce a new predefined name for the new PPO in Snames.ads and -- Introduce a new predefined name for the new PPO in Snames.ads and
-- Snames.adb. -- Snames.adb.
...@@ -149,9 +145,6 @@ package Exp_Disp is ...@@ -149,9 +145,6 @@ package Exp_Disp is
-- Categorize the new PPO name as predefined by adding an entry in -- Categorize the new PPO name as predefined by adding an entry in
-- Is_Predefined_Dispatching_Operation in Exp_Util.adb. -- 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_ -- Generate the specification of the new PPO in Make_Predefined_
-- Primitive_Spec in Exp_Ch3.adb. The Is_Internal flag of the defining -- Primitive_Spec in Exp_Ch3.adb. The Is_Internal flag of the defining
-- identifier of the specification must be set to True. -- identifier of the specification must be set to True.
...@@ -174,8 +167,6 @@ package Exp_Disp is ...@@ -174,8 +167,6 @@ package Exp_Disp is
-- Exp_Disp.Default_Prim_Op_Position - indirect use -- Exp_Disp.Default_Prim_Op_Position - indirect use
-- Exp_Disp.Set_All_DT_Position - direct use -- Exp_Disp.Set_All_DT_Position - direct use
Default_Prim_Op_Count : constant Int := 15;
type DT_Access_Action is type DT_Access_Action is
(CW_Membership, (CW_Membership,
IW_Membership, IW_Membership,
...@@ -184,6 +175,7 @@ package Exp_Disp is ...@@ -184,6 +175,7 @@ package Exp_Disp is
Get_Access_Level, Get_Access_Level,
Get_Entry_Index, Get_Entry_Index,
Get_External_Tag, Get_External_Tag,
Get_Predefined_Prim_Op_Address,
Get_Prim_Op_Address, Get_Prim_Op_Address,
Get_Prim_Op_Kind, Get_Prim_Op_Kind,
Get_RC_Offset, Get_RC_Offset,
...@@ -200,10 +192,12 @@ package Exp_Disp is ...@@ -200,10 +192,12 @@ package Exp_Disp is
Set_Interface_Table, Set_Interface_Table,
Set_Offset_Index, Set_Offset_Index,
Set_OSD, Set_OSD,
Set_Predefined_Prim_Op_Address,
Set_Prim_Op_Address, Set_Prim_Op_Address,
Set_Prim_Op_Kind, Set_Prim_Op_Kind,
Set_RC_Offset, Set_RC_Offset,
Set_Remotely_Callable, Set_Remotely_Callable,
Set_Signature,
Set_SSD, Set_SSD,
Set_TSD, Set_TSD,
Set_Tagged_Kind, 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