Skip to content

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

a-tags.ads, a-tags.adb: 

2006-10-31  Javier Miranda  <miranda@adacore.com>

	* a-tags.ads, a-tags.adb: 
	(Predefined_DT): New function that improves readability of the code.
	(Get_Predefined_Prim_Op_Address, Set_Predefined_Prim_Op_Address,
	Inherit_DT): Use the new function Predefined_DT to improve code
	readability.
	(Register_Interface_Tag): Update assertion.
	(Set_Interface_Table): Update assertion.
	(Interface_Ancestor_Tags): New subprogram required to implement AI-405:
	determining progenitor interfaces in Tags.
	(Inherit_CPP_DT): New subprogram.

        * exp_disp.adb (Expand_Interface_Thunk): Suppress checks during the
	analysis of the thunk code.
        (Expand_Interface_Conversion): Handle run-time conversion of
        access to class wide types.
	(Expand_Dispatching_Call): When generating the profile for the
	subprogram itype for a dispatching operation, properly terminate the
	formal parameters chaind list (set the Next_Entity of the last formal
	to Empty).
	(Collect_All_Interfaces): Removed. This routine has been moved to
	sem_util and renamed as Collect_All_Abstract_Interfaces.
	(Set_All_DT_Position): Hidden entities associated with abstract
	interface primitives are not taken into account in the check for
	3.9.3(10); this check is done with the aliased entity.
	(Make_DT, Set_All_DT_Position): Enable full ABI compatibility for
	interfacing with CPP by default.
	(Expand_Interface_Conversion): Add missing support for static conversion
	from an interface to a tagged type.
	(Collect_All_Interfaces): Add new out formal containing the list of
	abstract interface types to cleanup the subprogram Make_DT.
	(Make_DT): Update the code to generate the table of interfaces in case
	of abstract interface types.
	(Is_Predefined_Dispatching_Alias): New function that returns true if
	a primitive is not a predefined dispatching primitive but it is an
	alias of a predefined dispatching primitive.
	(Make_DT): If the ancestor of the type is a CPP_Class and we are
	compiling under full ABI compatibility mode we avoid the generation of
	calls to run-time services that fill the dispatch tables because under
	this mode we currently inherit the dispatch tables in the IP subprogram.
	(Write_DT): Emit an "is null" indication for a null procedure primitive.
	(Expand_Interface_Conversion): Use an address as the type of the formal
	of the internally built function that handles the case in which the
	target type is an access type.

From-SVN: r118244
parent 3cb8344b
Showing with 745 additions and 623 deletions
gcc/ada/a-tags.adb
...@@ -411,6 +411,11 @@ package body Ada.Tags is ...@@ -411,6 +411,11 @@ package body Ada.Tags is
-- Length of string represented by the given pointer (treating the string -- Length of string represented by the given pointer (treating the string
-- as a C-style string, which is Nul terminated). -- as a C-style string, which is Nul terminated).
function Predefined_DT (T : Tag) return Tag;
pragma Inline_Always (Predefined_DT);
-- Displace the Tag to reference the dispatch table containing the
-- predefined primitives.
function Typeinfo_Ptr (T : Tag) return System.Address; function Typeinfo_Ptr (T : Tag) return System.Address;
-- Returns the current value of the typeinfo_ptr component available in -- Returns the current value of the typeinfo_ptr component available in
-- the prologue of the dispatch table. -- the prologue of the dispatch table.
...@@ -596,7 +601,7 @@ package body Ada.Tags is ...@@ -596,7 +601,7 @@ package body Ada.Tags is
-- level of inheritance of both types, this can be computed in constant -- level of inheritance of both types, this can be computed in constant
-- time by the formula: -- time by the formula:
-- Obj'tag.TSD.Ancestor_Tags (Obj'tag.TSD.Idepth - Typ'tag.TSD.Idepth) -- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
-- = Typ'tag -- = Typ'tag
function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
...@@ -668,6 +673,13 @@ package body Ada.Tags is ...@@ -668,6 +673,13 @@ package body Ada.Tags is
end loop; end loop;
end if; end if;
-- Check if T is an immediate ancestor. This is required to handle
-- conversion of class-wide interfaces to tagged types.
if CW_Membership (Obj_DT, T) then
return Obj_Base;
end if;
-- If the object does not implement the interface we must raise CE -- If the object does not implement the interface we must raise CE
raise Constraint_Error; raise Constraint_Error;
...@@ -842,11 +854,10 @@ package body Ada.Tags is ...@@ -842,11 +854,10 @@ package body Ada.Tags is
(T : Tag; (T : Tag;
Position : Positive) return System.Address Position : Positive) return System.Address
is is
Prim_Ops_DT : constant Tag := To_Tag (To_Address (T) - DT_Prologue_Size);
begin begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
pragma Assert (Position <= Default_Prim_Op_Count); pragma Assert (Position <= Default_Prim_Op_Count);
return Prim_Ops_DT.Prims_Ptr (Position); return Predefined_DT (T).Prims_Ptr (Position);
end Get_Predefined_Prim_Op_Address; end Get_Predefined_Prim_Op_Address;
------------------------- -------------------------
...@@ -923,27 +934,59 @@ package body Ada.Tags is ...@@ -923,27 +934,59 @@ package body Ada.Tags is
return To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all; return To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all;
end Get_Tagged_Kind; end Get_Tagged_Kind;
--------------------
-- Inherit_CPP_DT --
--------------------
procedure Inherit_CPP_DT
(Old_T : Tag;
New_T : Tag;
Entry_Count : Natural)
is
begin
New_T.Prims_Ptr (1 .. Entry_Count) := Old_T.Prims_Ptr (1 .. Entry_Count);
end Inherit_CPP_DT;
---------------- ----------------
-- Inherit_DT -- -- Inherit_DT --
---------------- ----------------
procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural) is procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural) is
Old_T_Prim_Ops : Tag; subtype All_Predefined_Prims is
New_T_Prim_Ops : Tag; Positive range 1 .. Default_Prim_Op_Count;
Size : Positive;
begin begin
pragma Assert (Check_Signature (Old_T, Must_Be_Primary_Or_Secondary_DT)); pragma Assert (Check_Signature (Old_T, Must_Be_Primary_Or_Secondary_DT));
pragma Assert (Check_Signature (New_T, Must_Be_Primary_Or_Secondary_DT)); pragma Assert (Check_Signature (New_T, Must_Be_Primary_Or_Secondary_DT));
pragma Assert (Check_Size (Old_T, New_T, Entry_Count)); pragma Assert (Check_Size (Old_T, New_T, Entry_Count));
if Old_T /= null then if Old_T /= null then
-- Inherit the primitives of the parent
New_T.Prims_Ptr (1 .. Entry_Count) := New_T.Prims_Ptr (1 .. Entry_Count) :=
Old_T.Prims_Ptr (1 .. Entry_Count); Old_T.Prims_Ptr (1 .. Entry_Count);
Old_T_Prim_Ops := To_Tag (To_Address (Old_T) - DT_Prologue_Size);
New_T_Prim_Ops := To_Tag (To_Address (New_T) - DT_Prologue_Size); -- Inherit the predefined primitives of the parent
Size := Default_Prim_Op_Count;
New_T_Prim_Ops.Prims_Ptr (1 .. Size) := -- NOTE: In the following assignment we have to unactivate a warning
Old_T_Prim_Ops.Prims_Ptr (1 .. Size); -- generated by the compiler because of the following declaration of
-- the Dispatch_Table:
-- Prims_Ptr : Address_Array (1 .. 1);
-- This is a dummy declaration that is expanded by the frontend to
-- the correct size of the dispatch table corresponding with each
-- tagged type. As a consequence, if we try to use a constant to
-- copy the predefined elements (ie. Prims_Ptr (1 .. 15) := ...)
-- the compiler generates a warning indicating that Constraint_Error
-- will be raised at run-time (which is not true in this specific
-- case).
pragma Warnings (Off);
Predefined_DT (New_T).Prims_Ptr (All_Predefined_Prims) :=
Predefined_DT (Old_T).Prims_Ptr (All_Predefined_Prims);
pragma Warnings (On);
end if; end if;
end Inherit_DT; end Inherit_DT;
...@@ -994,6 +1037,35 @@ package body Ada.Tags is ...@@ -994,6 +1037,35 @@ package body Ada.Tags is
New_TSD_Ptr.Tags_Table (0) := New_Tag; New_TSD_Ptr.Tags_Table (0) := New_Tag;
end Inherit_TSD; end Inherit_TSD;
-----------------------------
-- Interface_Ancestor_Tags --
-----------------------------
function Interface_Ancestor_Tags (T : Tag) return Tag_Array is
Iface_Table : Interface_Data_Ptr;
begin
Iface_Table := To_Interface_Data_Ptr (TSD (T).Ifaces_Table_Ptr);
if Iface_Table = null then
declare
Table : Tag_Array (1 .. 0);
begin
return Table;
end;
else
declare
Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces);
begin
for J in 1 .. Iface_Table.Nb_Ifaces loop
Table (J) := Iface_Table.Table (J).Iface_Tag;
end loop;
return Table;
end;
end if;
end Interface_Ancestor_Tags;
------------------ ------------------
-- Internal_Tag -- -- Internal_Tag --
------------------ ------------------
...@@ -1107,21 +1179,24 @@ package body Ada.Tags is ...@@ -1107,21 +1179,24 @@ package body Ada.Tags is
(Obj : System.Address; (Obj : System.Address;
T : Tag) return SSE.Storage_Count T : Tag) return SSE.Storage_Count
is is
Parent_Slot : constant Positive := 1;
-- The tag of the parent is always in the first slot of the table of
-- ancestor tags.
Size_Slot : constant Positive := 1;
-- The pointer to the _size primitive is always in the first slot of
-- the dispatch table.
Parent_Tag : Tag; Parent_Tag : Tag;
-- The tag of the parent type through the dispatch table -- The tag of the parent type through the dispatch table
Prim_Ops_DT : Tag;
-- The table of primitive operations of the parent
F : Acc_Size; F : Acc_Size;
-- Access to the _size primitive of the parent. We assume that it is -- Access to the _size primitive of the parent
-- always in the first slot of the dispatch table.
begin begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
Parent_Tag := TSD (T).Tags_Table (1); Parent_Tag := TSD (T).Tags_Table (Parent_Slot);
Prim_Ops_DT := To_Tag (To_Address (Parent_Tag) - DT_Prologue_Size); F := To_Acc_Size (Predefined_DT (Parent_Tag).Prims_Ptr (Size_Slot));
F := To_Acc_Size (Prim_Ops_DT.Prims_Ptr (1));
-- Here we compute the size of the _parent field of the object -- Here we compute the size of the _parent field of the object
...@@ -1152,6 +1227,15 @@ package body Ada.Tags is ...@@ -1152,6 +1227,15 @@ package body Ada.Tags is
end if; end if;
end Parent_Tag; end Parent_Tag;
-------------------
-- Predefined_DT --
-------------------
function Predefined_DT (T : Tag) return Tag is
begin
return To_Tag (To_Address (T) - DT_Prologue_Size);
end Predefined_DT;
---------------------------- ----------------------------
-- Register_Interface_Tag -- -- Register_Interface_Tag --
---------------------------- ----------------------------
...@@ -1165,14 +1249,13 @@ package body Ada.Tags is ...@@ -1165,14 +1249,13 @@ package body Ada.Tags is
Iface_Table : Interface_Data_Ptr; Iface_Table : Interface_Data_Ptr;
begin begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
pragma Assert (Check_Signature (Interface_T, Must_Be_Interface)); pragma Assert (Check_Signature (Interface_T, Must_Be_Interface));
New_T_TSD := TSD (T); New_T_TSD := TSD (T);
Iface_Table := To_Interface_Data_Ptr (New_T_TSD.Ifaces_Table_Ptr); Iface_Table := To_Interface_Data_Ptr (New_T_TSD.Ifaces_Table_Ptr);
pragma Assert (Position <= Iface_Table.Nb_Ifaces); pragma Assert (Position <= Iface_Table.Nb_Ifaces);
Iface_Table.Table (Position).Iface_Tag := Interface_T; Iface_Table.Table (Position).Iface_Tag := Interface_T;
end Register_Interface_Tag; end Register_Interface_Tag;
...@@ -1237,7 +1320,7 @@ package body Ada.Tags is ...@@ -1237,7 +1320,7 @@ package body Ada.Tags is
procedure Set_Interface_Table (T : Tag; Value : System.Address) is procedure Set_Interface_Table (T : Tag; Value : System.Address) is
begin begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
TSD (T).Ifaces_Table_Ptr := Value; TSD (T).Ifaces_Table_Ptr := Value;
end Set_Interface_Table; end Set_Interface_Table;
...@@ -1308,18 +1391,22 @@ package body Ada.Tags is ...@@ -1308,18 +1391,22 @@ package body Ada.Tags is
pragma Assert pragma Assert
(Check_Signature (Prim_DT, Must_Be_Primary_DT)); (Check_Signature (Prim_DT, Must_Be_Primary_DT));
Sec_Base := This + Offset_Value; -- Save the offset to top field in the secondary dispatch table.
Sec_DT := To_Tag_Ptr (Sec_Base).all;
Offset_To_Top :=
To_Storage_Offset_Ptr (To_Address (Sec_DT) - K_Offset_To_Top);
pragma Assert if Offset_Value /= 0 then
(Check_Signature (Sec_DT, Must_Be_Secondary_DT)); Sec_Base := This + Offset_Value;
Sec_DT := To_Tag_Ptr (Sec_Base).all;
Offset_To_Top :=
To_Storage_Offset_Ptr (To_Address (Sec_DT) - K_Offset_To_Top);
if Is_Static then pragma Assert
Offset_To_Top.all := Offset_Value; (Check_Signature (Sec_DT, Must_Be_Secondary_DT));
else
Offset_To_Top.all := SSE.Storage_Offset'Last; if Is_Static then
Offset_To_Top.all := Offset_Value;
else
Offset_To_Top.all := SSE.Storage_Offset'Last;
end if;
end if; end if;
-- Save Offset_Value in the table of interfaces of the primary DT. This -- Save Offset_Value in the table of interfaces of the primary DT. This
...@@ -1373,11 +1460,10 @@ package body Ada.Tags is ...@@ -1373,11 +1460,10 @@ package body Ada.Tags is
Position : Positive; Position : Positive;
Value : System.Address) Value : System.Address)
is is
Prim_Ops_DT : constant Tag := To_Tag (To_Address (T) - DT_Prologue_Size);
begin begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
pragma Assert (Position >= 1 and then Position <= Default_Prim_Op_Count); pragma Assert (Position >= 1 and then Position <= Default_Prim_Op_Count);
Prim_Ops_DT.Prims_Ptr (Position) := Value; Predefined_DT (T).Prims_Ptr (Position) := Value;
end Set_Predefined_Prim_Op_Address; end Set_Predefined_Prim_Op_Address;
------------------------- -------------------------
......
gcc/ada/a-tags.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -44,11 +44,18 @@ package Ada.Tags is ...@@ -44,11 +44,18 @@ package Ada.Tags is
-- In accordance with Ada 2005 AI-362 -- In accordance with Ada 2005 AI-362
type Tag is private; type Tag is private;
pragma Preelaborable_Initialization (Tag);
No_Tag : constant Tag; No_Tag : constant Tag;
function Expanded_Name (T : Tag) return String; function Expanded_Name (T : Tag) return String;
function Wide_Expanded_Name (T : Tag) return Wide_String;
pragma Ada_05 (Wide_Expanded_Name);
function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String;
pragma Ada_05 (Wide_Wide_Expanded_Name);
function External_Tag (T : Tag) return String; function External_Tag (T : Tag) return String;
function Internal_Tag (External : String) return Tag; function Internal_Tag (External : String) return Tag;
...@@ -66,13 +73,12 @@ package Ada.Tags is ...@@ -66,13 +73,12 @@ package Ada.Tags is
function Parent_Tag (T : Tag) return Tag; function Parent_Tag (T : Tag) return Tag;
pragma Ada_05 (Parent_Tag); pragma Ada_05 (Parent_Tag);
Tag_Error : exception; type Tag_Array is array (Positive range <>) of Tag;
function Wide_Expanded_Name (T : Tag) return Wide_String; function Interface_Ancestor_Tags (T : Tag) return Tag_Array;
pragma Ada_05 (Wide_Expanded_Name); pragma Ada_05 (Interface_Ancestor_Tags);
function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String; Tag_Error : exception;
pragma Ada_05 (Wide_Wide_Expanded_Name);
private private
-- The following subprogram specifications are placed here instead of -- The following subprogram specifications are placed here instead of
...@@ -192,7 +198,7 @@ private ...@@ -192,7 +198,7 @@ private
-- type I is interface; -- type I is interface;
-- type T is tagged ... -- type T is tagged ...
-- --
-- function Test (O : in I'Class) is -- function Test (O : I'Class) is
-- begin -- begin
-- return O in T'Class. -- return O in T'Class.
-- end Test; -- end Test;
...@@ -257,6 +263,11 @@ private ...@@ -257,6 +263,11 @@ private
-- return the tagged kind of a type in the context of concurrency and -- return the tagged kind of a type in the context of concurrency and
-- limitedness. -- limitedness.
procedure Inherit_CPP_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural);
-- Entry point used to initialize the DT of a type knowing the tag
-- of the direct CPP ancestor and the number of primitive ops that
-- are inherited (Entry_Count).
procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural); procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural);
-- Entry point used to initialize the DT of a type knowing the tag -- Entry point used to initialize the DT of a type knowing the tag
-- of the direct ancestor and the number of primitive ops that are -- of the direct ancestor and the number of primitive ops that are
......
gcc/ada/exp_disp.adb
...@@ -34,6 +34,7 @@ with Exp_Ch7; use Exp_Ch7; ...@@ -34,6 +34,7 @@ with Exp_Ch7; use Exp_Ch7;
with Exp_Dbug; use Exp_Dbug; with Exp_Dbug; use Exp_Dbug;
with Exp_Tss; use Exp_Tss; with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Itypes; use Itypes; with Itypes; use Itypes;
with Nlists; use Nlists; with Nlists; use Nlists;
with Nmake; use Nmake; with Nmake; use Nmake;
...@@ -414,15 +415,14 @@ package body Exp_Disp is ...@@ -414,15 +415,14 @@ package body Exp_Disp is
TSD_Entry_Size => 0, TSD_Entry_Size => 0,
TSD_Prologue_Size => 0); TSD_Prologue_Size => 0);
procedure Collect_All_Interfaces (T : Entity_Id);
-- Ada 2005 (AI-251): Collect the whole list of interfaces that are
-- directly or indirectly implemented by T. Used to compute the size
-- of the table of interfaces.
function Default_Prim_Op_Position (E : Entity_Id) return Uint; 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.
function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean;
-- Returns true if Prim is not a predefined dispatching primitive but it is
-- an alias of a predefined dispatching primitive (ie. through a renaming)
function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean; function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
-- Check if the type has a private view or if the public view appears -- Check if the type has a private view or if the public view appears
-- in the visible part of a package spec. -- in the visible part of a package spec.
...@@ -438,95 +438,6 @@ package body Exp_Disp is ...@@ -438,95 +438,6 @@ package body Exp_Disp is
-- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
-- to an RE_Tagged_Kind enumeration value. -- to an RE_Tagged_Kind enumeration value.
----------------------------
-- Collect_All_Interfaces --
----------------------------
procedure Collect_All_Interfaces (T : Entity_Id) is
procedure Add_Interface (Iface : Entity_Id);
-- Add the interface it if is not already in the list
procedure Collect (Typ : Entity_Id);
-- Subsidiary subprogram used to traverse the whole list
-- of directly and indirectly implemented interfaces
-------------------
-- Add_Interface --
-------------------
procedure Add_Interface (Iface : Entity_Id) is
Elmt : Elmt_Id;
begin
Elmt := First_Elmt (Abstract_Interfaces (T));
while Present (Elmt) and then Node (Elmt) /= Iface loop
Next_Elmt (Elmt);
end loop;
if No (Elmt) then
Append_Elmt (Iface, Abstract_Interfaces (T));
end if;
end Add_Interface;
-------------
-- Collect --
-------------
procedure Collect (Typ : Entity_Id) is
Ancestor : Entity_Id;
Id : Node_Id;
Iface : Entity_Id;
Nod : Node_Id;
begin
if Ekind (Typ) = E_Record_Type_With_Private then
Nod := Type_Definition (Parent (Full_View (Typ)));
else
Nod := Type_Definition (Parent (Typ));
end if;
pragma Assert (False
or else Nkind (Nod) = N_Derived_Type_Definition
or else Nkind (Nod) = N_Record_Definition);
-- Include the ancestor if we are generating the whole list
-- of interfaces. This is used to know the size of the table
-- that stores the tag of all the ancestor interfaces.
Ancestor := Etype (Typ);
if Ancestor /= Typ then
Collect (Ancestor);
end if;
if Is_Interface (Ancestor) then
Add_Interface (Ancestor);
end if;
-- Traverse the graph of ancestor interfaces
if Is_Non_Empty_List (Interface_List (Nod)) then
Id := First (Interface_List (Nod));
while Present (Id) loop
Iface := Etype (Id);
if Is_Interface (Iface) then
Add_Interface (Iface);
Collect (Iface);
end if;
Next (Id);
end loop;
end if;
end Collect;
-- Start of processing for Collect_All_Interfaces
begin
Collect (T);
end Collect_All_Interfaces;
------------------------------ ------------------------------
-- Default_Prim_Op_Position -- -- Default_Prim_Op_Position --
------------------------------ ------------------------------
...@@ -601,8 +512,8 @@ package body Exp_Disp is ...@@ -601,8 +512,8 @@ package body Exp_Disp is
Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node); Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node);
Param_List : constant List_Id := Parameter_Associations (Call_Node); Param_List : constant List_Id := Parameter_Associations (Call_Node);
Subp : Entity_Id := Entity (Name (Call_Node));
Subp : Entity_Id;
CW_Typ : Entity_Id; CW_Typ : Entity_Id;
New_Call : Node_Id; New_Call : Node_Id;
New_Call_Name : Node_Id; New_Call_Name : Node_Id;
...@@ -620,9 +531,6 @@ package body Exp_Disp is ...@@ -620,9 +531,6 @@ package body Exp_Disp is
-- to Duplicate_Subexpr with an explicit dereference when From is an -- to Duplicate_Subexpr with an explicit dereference when From is an
-- access parameter. -- access parameter.
function Controlling_Type (Subp : Entity_Id) return Entity_Id;
-- Returns the tagged type for which Subp is a primitive subprogram
--------------- ---------------
-- New_Value -- -- New_Value --
--------------- ---------------
...@@ -631,55 +539,23 @@ package body Exp_Disp is ...@@ -631,55 +539,23 @@ package body Exp_Disp is
Res : constant Node_Id := Duplicate_Subexpr (From); Res : constant Node_Id := Duplicate_Subexpr (From);
begin begin
if Is_Access_Type (Etype (From)) then if Is_Access_Type (Etype (From)) then
return Make_Explicit_Dereference (Sloc (From), Res); return
Make_Explicit_Dereference (Sloc (From),
Prefix => Res);
else else
return Res; return Res;
end if; end if;
end New_Value; end New_Value;
----------------------
-- Controlling_Type --
----------------------
function Controlling_Type (Subp : Entity_Id) return Entity_Id is
begin
if Ekind (Subp) = E_Function
and then Has_Controlling_Result (Subp)
then
return Base_Type (Etype (Subp));
else
declare
Formal : Entity_Id;
begin
Formal := First_Formal (Subp);
while Present (Formal) loop
if Is_Controlling_Formal (Formal) then
if Is_Access_Type (Etype (Formal)) then
return Base_Type (Designated_Type (Etype (Formal)));
else
return Base_Type (Etype (Formal));
end if;
end if;
Next_Formal (Formal);
end loop;
end;
end if;
-- Controlling type not found (should never happen)
return Empty;
end Controlling_Type;
-- Start of processing for Expand_Dispatching_Call -- Start of processing for Expand_Dispatching_Call
begin begin
Check_Restriction (No_Dispatching_Calls, Call_Node); Check_Restriction (No_Dispatching_Calls, Call_Node);
-- If this is an inherited operation that was overridden, the body -- Set subprogram. If this is an inherited operation that was
-- that is being called is its alias. -- overridden, the body that is being called is its alias.
Subp := Entity (Name (Call_Node));
if Present (Alias (Subp)) if Present (Alias (Subp))
and then Is_Inherited_Operation (Subp) and then Is_Inherited_Operation (Subp)
...@@ -711,7 +587,7 @@ package body Exp_Disp is ...@@ -711,7 +587,7 @@ package body Exp_Disp is
or else (RTE_Available (RE_Interface_Tag) or else (RTE_Available (RE_Interface_Tag)
and then Etype (Ctrl_Arg) = RTE (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 (Find_Dispatching_Type (Subp));
elsif Is_Access_Type (Etype (Ctrl_Arg)) then elsif Is_Access_Type (Etype (Ctrl_Arg)) then
CW_Typ := Designated_Type (Etype (Ctrl_Arg)); CW_Typ := Designated_Type (Etype (Ctrl_Arg));
...@@ -730,6 +606,8 @@ package body Exp_Disp is ...@@ -730,6 +606,8 @@ package body Exp_Disp is
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
end if; end if;
-- Why do we check the Root_Type instead of Typ???
if Is_CPP_Class (Root_Type (Typ)) then if Is_CPP_Class (Root_Type (Typ)) then
-- Create a new parameter list with the displaced 'this' -- Create a new parameter list with the displaced 'this'
...@@ -888,6 +766,8 @@ package body Exp_Disp is ...@@ -888,6 +766,8 @@ package body Exp_Disp is
Next_Entity (New_Formal); Next_Entity (New_Formal);
Next_Actual (Param); Next_Actual (Param);
end loop; end loop;
Set_Next_Entity (New_Formal, Empty);
Set_Last_Entity (Subp_Typ, Extra); Set_Last_Entity (Subp_Typ, Extra);
-- Copy extra formals -- Copy extra formals
...@@ -942,7 +822,9 @@ package body Exp_Disp is ...@@ -942,7 +822,9 @@ 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));
if Is_Predefined_Dispatching_Operation (Subp) then if Is_Predefined_Dispatching_Operation (Subp)
or else Is_Predefined_Dispatching_Alias (Subp)
then
New_Call_Name := New_Call_Name :=
Unchecked_Convert_To (Subp_Ptr_Typ, Unchecked_Convert_To (Subp_Ptr_Typ,
Make_DT_Access_Action (Typ, Make_DT_Access_Action (Typ,
...@@ -1056,14 +938,15 @@ package body Exp_Disp is ...@@ -1056,14 +938,15 @@ package body Exp_Disp is
Is_Static : Boolean := True) Is_Static : Boolean := True)
is is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Etyp : constant Entity_Id := Etype (N);
Operand : constant Node_Id := Expression (N); Operand : constant Node_Id := Expression (N);
Operand_Typ : Entity_Id := Etype (Operand); Operand_Typ : Entity_Id := Etype (Operand);
Iface_Typ : Entity_Id := Etype (N);
Iface_Tag : Entity_Id;
Fent : Entity_Id; Fent : Entity_Id;
Func : Node_Id; Func : Node_Id;
Iface_Typ : Entity_Id := Etype (N);
Iface_Tag : Entity_Id;
New_Itype : Entity_Id;
P : Node_Id; P : Node_Id;
Null_Op_Nod : Node_Id;
begin begin
pragma Assert (Nkind (Operand) /= N_Attribute_Reference); pragma Assert (Nkind (Operand) /= N_Attribute_Reference);
...@@ -1089,8 +972,9 @@ package body Exp_Disp is ...@@ -1089,8 +972,9 @@ package body Exp_Disp is
Iface_Typ := Etype (Iface_Typ); Iface_Typ := Etype (Iface_Typ);
end if; end if;
pragma Assert (not Is_Class_Wide_Type (Iface_Typ) pragma Assert (not Is_Static
and then Is_Interface (Iface_Typ)); or else (not Is_Class_Wide_Type (Iface_Typ)
and then Is_Interface (Iface_Typ)));
if not Is_Static then if not Is_Static then
...@@ -1101,6 +985,40 @@ package body Exp_Disp is ...@@ -1101,6 +985,40 @@ package body Exp_Disp is
return; return;
end if; end if;
-- Handle conversion of access to class-wide interface types. The
-- target can be an access to object or an access to another class
-- wide interfac (see -1- and -2- in the following example):
-- type Iface1_Ref is access all Iface1'Class;
-- type Iface2_Ref is access all Iface1'Class;
-- Acc1 : Iface1_Ref := new ...
-- Obj : Obj_Ref := Obj_Ref (Acc); -- 1
-- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
if Is_Access_Type (Operand_Typ) then
pragma Assert
(Is_Class_Wide_Type (Directly_Designated_Type (Operand_Typ))
and then
Is_Interface (Directly_Designated_Type (Operand_Typ)));
Rewrite (N,
Unchecked_Convert_To (Etype (N),
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Displace), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address),
Relocate_Node (Expression (N))),
New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
Loc)))));
Analyze (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),
...@@ -1108,30 +1026,28 @@ package body Exp_Disp is ...@@ -1108,30 +1026,28 @@ package body Exp_Disp is
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Expression (N)), Prefix => Relocate_Node (Expression (N)),
Attribute_Name => Name_Address), Attribute_Name => Name_Address),
New_Occurrence_Of New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table (Iface_Typ))), (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
Loc)))); Loc))));
Analyze (N); Analyze (N);
-- Change the type of the data returned by IW_Convert to -- If the target is a class-wide interface we change the type of the
-- indicate that this is a dispatching call. -- data returned by IW_Convert to indicate that this is a dispatching
-- call.
declare New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
New_Itype : Entity_Id; Set_Etype (New_Itype, New_Itype);
Init_Esize (New_Itype);
begin Init_Size_Align (New_Itype);
New_Itype := Create_Itype (E_Anonymous_Access_Type, N); Set_Directly_Designated_Type (New_Itype, Etyp);
Set_Etype (New_Itype, New_Itype);
Init_Size_Align (New_Itype);
Set_Directly_Designated_Type (New_Itype,
Class_Wide_Type (Iface_Typ));
Rewrite (N, Make_Explicit_Dereference (Loc, Rewrite (N, Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (New_Itype, Unchecked_Convert_To (New_Itype,
Relocate_Node (N)))); Relocate_Node (N))));
Analyze (N); Analyze (N);
end; Freeze_Itype (New_Itype, N);
return; return;
end if; end if;
...@@ -1157,23 +1073,33 @@ package body Exp_Disp is ...@@ -1157,23 +1073,33 @@ package body Exp_Disp is
-- conversion that will be expanded in the code that returns -- conversion that will be expanded in the code that returns
-- the value of the displaced actual. That is: -- the value of the displaced actual. That is:
-- function Func (O : Operand_Typ) return Iface_Typ is -- function Func (O : Address) return Iface_Typ is
-- begin -- begin
-- if O = null then -- if O = Null_Address then
-- return null; -- return null;
-- else -- else
-- return Iface_Typ!(O); -- return Iface_Typ!(Operand_Typ!(O).Iface_Tag'Address);
-- end if; -- end if;
-- end Func; -- end Func;
Fent := Fent := Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
Make_Defining_Identifier (Loc, New_Internal_Name ('F')); Set_Is_Internal (Fent);
declare
Desig_Typ : Entity_Id;
begin
Desig_Typ := Etype (Expression (N));
-- Decorate the "null" in the if-statement condition if Is_Access_Type (Desig_Typ) then
Desig_Typ := Directly_Designated_Type (Desig_Typ);
end if;
Null_Op_Nod := Make_Null (Loc); New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
Set_Etype (Null_Op_Nod, Etype (Operand)); Set_Etype (New_Itype, New_Itype);
Set_Analyzed (Null_Op_Nod); Set_Scope (New_Itype, Fent);
Init_Size_Align (New_Itype);
Set_Directly_Designated_Type (New_Itype, Desig_Typ);
end;
Func := Func :=
Make_Subprogram_Body (Loc, Make_Subprogram_Body (Loc,
...@@ -1186,7 +1112,8 @@ package body Exp_Disp is ...@@ -1186,7 +1112,8 @@ package body Exp_Disp is
Defining_Identifier => Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uO), Make_Defining_Identifier (Loc, Name_uO),
Parameter_Type => Parameter_Type =>
New_Reference_To (Etype (Operand), Loc))), New_Reference_To (RTE (RE_Address), Loc))),
Result_Definition => Result_Definition =>
New_Reference_To (Etype (N), Loc)), New_Reference_To (Etype (N), Loc)),
...@@ -1199,20 +1126,24 @@ package body Exp_Disp is ...@@ -1199,20 +1126,24 @@ package body Exp_Disp is
Condition => Condition =>
Make_Op_Eq (Loc, Make_Op_Eq (Loc,
Left_Opnd => Make_Identifier (Loc, Name_uO), Left_Opnd => Make_Identifier (Loc, Name_uO),
Right_Opnd => Null_Op_Nod), Right_Opnd => New_Reference_To
(RTE (RE_Null_Address), Loc)),
Then_Statements => New_List ( Then_Statements => New_List (
Make_Return_Statement (Loc, Make_Return_Statement (Loc,
Make_Null (Loc))), Make_Null (Loc))),
Else_Statements => New_List ( Else_Statements => New_List (
Make_Return_Statement (Loc, Make_Return_Statement (Loc,
Unchecked_Convert_To (Etype (N), Unchecked_Convert_To (Etype (N),
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uO), Prefix => Unchecked_Convert_To (New_Itype,
Selector_Name => Make_Identifier (Loc, Name_uO)),
New_Occurrence_Of (Iface_Tag, Loc)), Selector_Name =>
Attribute_Name => Name_Address)))))))); New_Occurrence_Of (Iface_Tag, Loc)),
Attribute_Name => Name_Address))))))));
-- Insert the new declaration in the nearest enclosing scope -- Insert the new declaration in the nearest enclosing scope
-- that has declarations. -- that has declarations.
...@@ -1234,11 +1165,32 @@ package body Exp_Disp is ...@@ -1234,11 +1165,32 @@ package body Exp_Disp is
Analyze (Func); Analyze (Func);
Rewrite (N, if Is_Access_Type (Etype (Expression (N))) then
Make_Function_Call (Loc,
Name => New_Reference_To (Fent, Loc), -- Generate: Operand_Typ!(Expression.all)'Address
Parameter_Associations => New_List (
Relocate_Node (Expression (N))))); Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (Fent, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Unchecked_Convert_To (Operand_Typ,
Make_Explicit_Dereference (Loc,
Relocate_Node (Expression (N)))),
Attribute_Name => Name_Address))));
else
-- Generate: Operand_Typ!(Expression)'Address
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (Fent, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Unchecked_Convert_To (Operand_Typ,
Relocate_Node (Expression (N))),
Attribute_Name => Name_Address))));
end if;
end if; end if;
Analyze (N); Analyze (N);
...@@ -1484,7 +1436,7 @@ package body Exp_Disp is ...@@ -1484,7 +1436,7 @@ package body Exp_Disp is
-- Example: -- Example:
-- type I is interface; -- type I is interface;
-- procedure P (X : in I) is abstract; -- procedure P (X : I) is abstract;
-- type T is tagged null record; -- type T is tagged null record;
-- procedure P (X : T); -- procedure P (X : T);
...@@ -1665,7 +1617,11 @@ package body Exp_Disp is ...@@ -1665,7 +1617,11 @@ package body Exp_Disp is
Parameter_Associations => Actuals))))); Parameter_Associations => Actuals)))));
end if; end if;
Analyze (New_Code); -- Analyze the code of the thunk with checks suppressed because we are
-- in the middle of building the dispatch information itself and some
-- characteristics of the type may not be fully available.
Analyze (New_Code, Suppress => All_Checks);
return New_Code; return New_Code;
end Expand_Interface_Thunk; end Expand_Interface_Thunk;
...@@ -1686,7 +1642,9 @@ package body Exp_Disp is ...@@ -1686,7 +1642,9 @@ package body Exp_Disp is
begin begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls)); pragma Assert (not Restriction_Active (No_Dispatching_Calls));
if Is_Predefined_Dispatching_Operation (Prim) then if Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim)
then
return return
Make_DT_Access_Action (Typ, Make_DT_Access_Action (Typ,
Action => Set_Predefined_Prim_Op_Address, Action => Set_Predefined_Prim_Op_Address,
...@@ -1734,7 +1692,9 @@ package body Exp_Disp is ...@@ -1734,7 +1692,9 @@ package body Exp_Disp is
First_Tag_Component (Scope (DTC_Entity (Iface_Prim))); First_Tag_Component (Scope (DTC_Entity (Iface_Prim)));
begin begin
if Is_Predefined_Dispatching_Operation (Prim) then if Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim)
then
return return
Make_DT_Access_Action (Typ, Make_DT_Access_Action (Typ,
Action => Set_Predefined_Prim_Op_Address, Action => Set_Predefined_Prim_Op_Address,
...@@ -1829,6 +1789,31 @@ package body Exp_Disp is ...@@ -1829,6 +1789,31 @@ package body Exp_Disp is
return Result; return Result;
end Init_Predefined_Interface_Primitives; end Init_Predefined_Interface_Primitives;
-------------------------------------
-- Is_Predefined_Dispatching_Alias --
-------------------------------------
function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean
is
E : Entity_Id;
begin
if not Is_Predefined_Dispatching_Operation (Prim)
and then Present (Alias (Prim))
then
E := Prim;
while Present (Alias (E)) loop
E := Alias (E);
end loop;
if Is_Predefined_Dispatching_Operation (E) then
return True;
end if;
end if;
return False;
end Is_Predefined_Dispatching_Alias;
---------------------------------------- ----------------------------------------
-- Make_Disp_Asynchronous_Select_Body -- -- Make_Disp_Asynchronous_Select_Body --
---------------------------------------- ----------------------------------------
...@@ -2687,9 +2672,10 @@ package body Exp_Disp is ...@@ -2687,9 +2672,10 @@ package body Exp_Disp is
Size_Expr_Node : Node_Id; Size_Expr_Node : Node_Id;
TSD_Num_Entries : Int; TSD_Num_Entries : Int;
Ancestor_Copy : Entity_Id;
Empty_DT : Boolean := False; Empty_DT : Boolean := False;
Typ_Copy : Entity_Id;
Ancestor_Ifaces : Elist_Id;
Typ_Ifaces : Elist_Id;
begin begin
if not RTE_Available (RE_Tag) then if not RTE_Available (RE_Tag) then
...@@ -2697,85 +2683,80 @@ package body Exp_Disp is ...@@ -2697,85 +2683,80 @@ package body Exp_Disp is
return New_List; return New_List;
end if; end if;
-- Calculate the size of the DT and the TSD -- Calculate the size of the DT and the TSD. First we count the number
-- of interfaces implemented by the ancestors
if Is_Interface (Typ) then
-- Abstract interfaces need neither the DT nor the ancestors table. Parent_Num_Ifaces := 0;
-- We reserve a single entry for its DT because at run-time the Num_Ifaces := 0;
-- pointer to this dummy DT will be used as the tag of this abstract
-- interface type.
Empty_DT := True; -- Count the abstract interfaces of the ancestors
Nb_Prim := 1;
TSD_Num_Entries := 0;
Num_Ifaces := 0;
else if Typ /= Etype (Typ) then
-- Count the number of interfaces implemented by the ancestors Collect_Abstract_Interfaces (Etype (Typ), Ancestor_Ifaces);
Parent_Num_Ifaces := 0; AI := First_Elmt (Ancestor_Ifaces);
Num_Ifaces := 0; while Present (AI) loop
Parent_Num_Ifaces := Parent_Num_Ifaces + 1;
Next_Elmt (AI);
end loop;
end if;
if Typ /= Etype (Typ) then -- Count the number of additional interfaces implemented by Typ
Ancestor_Copy := New_Copy (Etype (Typ));
Set_Parent (Ancestor_Copy, Parent (Etype (Typ)));
Set_Abstract_Interfaces (Ancestor_Copy, New_Elmt_List);
Collect_All_Interfaces (Ancestor_Copy);
AI := First_Elmt (Abstract_Interfaces (Ancestor_Copy)); Collect_Abstract_Interfaces (Typ, Typ_Ifaces);
while Present (AI) loop
Parent_Num_Ifaces := Parent_Num_Ifaces + 1;
Next_Elmt (AI);
end loop;
end if;
-- Count the number of additional interfaces implemented by Typ AI := First_Elmt (Typ_Ifaces);
while Present (AI) loop
Num_Ifaces := Num_Ifaces + 1;
Next_Elmt (AI);
end loop;
Typ_Copy := New_Copy (Typ); -- Count ancestors to compute the inheritance depth. For private
Set_Parent (Typ_Copy, Parent (Typ)); -- extensions, always go to the full view in order to compute the
Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List); -- real inheritance depth.
Collect_All_Interfaces (Typ_Copy);
AI := First_Elmt (Abstract_Interfaces (Typ_Copy)); declare
while Present (AI) loop Parent_Type : Entity_Id := Typ;
Num_Ifaces := Num_Ifaces + 1; P : Entity_Id;
Next_Elmt (AI);
end loop;
-- Count ancestors to compute the inheritance depth. For private begin
-- extensions, always go to the full view in order to compute the I_Depth := 0;
-- real inheritance depth. loop
P := Etype (Parent_Type);
declare if Is_Private_Type (P) then
Parent_Type : Entity_Id := Typ; P := Full_View (Base_Type (P));
P : Entity_Id; end if;
begin exit when P = Parent_Type;
I_Depth := 0;
loop
P := Etype (Parent_Type);
if Is_Private_Type (P) then I_Depth := I_Depth + 1;
P := Full_View (Base_Type (P)); Parent_Type := P;
end if; end loop;
end;
exit when P = Parent_Type; -- Abstract interfaces don't need the DT. 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. The table of
-- interfaces is required to give support to AI-405
I_Depth := I_Depth + 1; if Is_Interface (Typ) then
Parent_Type := P; Empty_DT := True;
end loop; Nb_Prim := 1;
end; TSD_Num_Entries := 0;
else
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 0 (or we are compiling with -- If the number of primitives of Typ is 0 (or we are compiling
-- the No_Dispatching_Calls restriction) we reserve a dummy single -- with the No_Dispatching_Calls restriction) we reserve a dummy
-- entry for its DT because at run-time the pointer to this dummy DT -- single entry for its DT because at run-time the pointer to this
-- will be used as the tag of this tagged type. -- dummy DT will be used as the tag of this tagged type.
if Nb_Prim = 0 or else Restriction_Active (No_Dispatching_Calls) then if Nb_Prim = 0
or else Restriction_Active (No_Dispatching_Calls)
then
Empty_DT := True; Empty_DT := True;
Nb_Prim := 1; Nb_Prim := 1;
end if; end if;
...@@ -2789,9 +2770,7 @@ package body Exp_Disp is ...@@ -2789,9 +2770,7 @@ package body Exp_Disp is
Set_Ekind (DT_Ptr, E_Variable); Set_Ekind (DT_Ptr, E_Variable);
Set_Is_Statically_Allocated (DT_Ptr); Set_Is_Statically_Allocated (DT_Ptr);
if not Is_Interface (Typ) if Num_Ifaces > 0 then
and then Num_Ifaces > 0
then
Name_ITable := New_External_Name (Tname, 'I'); Name_ITable := New_External_Name (Tname, 'I');
ITable := Make_Defining_Identifier (Loc, Name_ITable); ITable := Make_Defining_Identifier (Loc, Name_ITable);
...@@ -2936,21 +2915,23 @@ package body Exp_Disp is ...@@ -2936,21 +2915,23 @@ package body Exp_Disp is
-- Generate: -- Generate:
-- Set_Signature (DT_Ptr, Value); -- Set_Signature (DT_Ptr, Value);
if Is_Interface (Typ) then if RTE_Available (RE_Set_Signature) then
Append_To (Elab_Code, if Is_Interface (Typ) then
Make_DT_Access_Action (Typ, Append_To (Elab_Code,
Action => Set_Signature, Make_DT_Access_Action (Typ,
Args => New_List ( Action => Set_Signature,
New_Reference_To (DT_Ptr, Loc), -- DTptr Args => New_List (
New_Reference_To (RTE (RE_Abstract_Interface), Loc)))); New_Reference_To (DT_Ptr, Loc), -- DTptr
New_Reference_To (RTE (RE_Abstract_Interface), Loc))));
elsif RTE_Available (RE_Set_Signature) then else
Append_To (Elab_Code, Append_To (Elab_Code,
Make_DT_Access_Action (Typ, Make_DT_Access_Action (Typ,
Action => Set_Signature, Action => Set_Signature,
Args => New_List ( Args => New_List (
New_Reference_To (DT_Ptr, Loc), -- DTptr New_Reference_To (DT_Ptr, Loc), -- DTptr
New_Reference_To (RTE (RE_Primary_DT), Loc)))); New_Reference_To (RTE (RE_Primary_DT), Loc))));
end if;
end if; 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
...@@ -2968,10 +2949,7 @@ package body Exp_Disp is ...@@ -2968,10 +2949,7 @@ package body Exp_Disp is
-- Set the pointer to the Interfaces_Table (if any). Otherwise the -- Set the pointer to the Interfaces_Table (if any). Otherwise the
-- corresponding access component is set to null. -- corresponding access component is set to null.
if Is_Interface (Typ) then if Num_Ifaces = 0 then
null;
elsif Num_Ifaces = 0 then
if RTE_Available (RE_Set_Interface_Table) then if RTE_Available (RE_Set_Interface_Table) then
Append_To (Elab_Code, Append_To (Elab_Code,
Make_DT_Access_Action (Typ, Make_DT_Access_Action (Typ,
...@@ -3121,155 +3099,168 @@ package body Exp_Disp is ...@@ -3121,155 +3099,168 @@ package body Exp_Disp is
Node2 => Make_Integer_Literal (Loc, Type_Access_Level (Typ))))); Node2 => Make_Integer_Literal (Loc, Type_Access_Level (Typ)))));
end if; end if;
if Typ = Etype (Typ) -- If the ancestor is a CPP_Class type we inherit the dispatch tables
or else Is_CPP_Class (Etype (Typ)) -- in the init proc, and we don't need to fill them in here.
or else Is_Interface (Typ)
then
Old_Tag1 :=
Unchecked_Convert_To (Generalized_Tag,
Make_Integer_Literal (Loc, 0));
Old_Tag2 :=
Unchecked_Convert_To (Generalized_Tag,
Make_Integer_Literal (Loc, 0));
else if Is_CPP_Class (Etype (Typ)) and then not Debug_Flag_QQ then
Old_Tag1 := null;
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
Old_Tag2 :=
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
end if;
if Typ /= Etype (Typ) -- Otherwise we fill in the dispatch tables here
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 else
if Restriction_Active (No_Dispatching_Calls) then if Typ = Etype (Typ)
Append_To (Elab_Code, or else Is_CPP_Class (Etype (Typ))
Make_DT_Access_Action (Typ, or else Is_Interface (Typ)
Action => Inherit_DT, then
Args => New_List ( Old_Tag1 :=
Node1 => Old_Tag1, Unchecked_Convert_To (Generalized_Tag,
Node2 => New_Reference_To (DT_Ptr, Loc), Make_Integer_Literal (Loc, 0));
Node3 => Make_Integer_Literal (Loc, Uint_0)))); Old_Tag2 :=
else Unchecked_Convert_To (Generalized_Tag,
Append_To (Elab_Code, Make_Integer_Literal (Loc, 0));
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 else
Old_Tag1 :=
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
Old_Tag2 :=
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
end if;
if not Restriction_Active (No_Dispatching_Calls) if Typ /= Etype (Typ)
and then not Is_CPP_Class (Etype (Typ)) and then not Is_Interface (Typ)
and then not Restriction_Active (No_Dispatching_Calls)
then then
declare -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
Sec_DT_Ancestor : Elmt_Id :=
Next_Elmt
(First_Elmt
(Access_Disp_Table (Etype (Typ))));
Sec_DT_Typ : Elmt_Id :=
Next_Elmt
(First_Elmt
(Access_Disp_Table (Typ)));
procedure Copy_Secondary_DTs (Typ : Entity_Id);
-- Local procedure required to climb through the ancestors and
-- copy the contents of all their secondary dispatch tables.
------------------------
-- Copy_Secondary_DTs --
------------------------
procedure Copy_Secondary_DTs (Typ : Entity_Id) is
E : Entity_Id;
Iface : Elmt_Id;
begin if not Is_Interface (Etype (Typ)) then
-- Climb to the ancestor (if any) handling private types 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;
if Present (Full_View (Etype (Typ))) then -- Inherit the secondary dispatch tables of the ancestor
if Full_View (Etype (Typ)) /= Typ then
Copy_Secondary_DTs (Full_View (Etype (Typ)));
end if;
elsif Etype (Typ) /= Typ then if not Restriction_Active (No_Dispatching_Calls)
Copy_Secondary_DTs (Etype (Typ)); and then not Is_CPP_Class (Etype (Typ))
end if; then
declare
Sec_DT_Ancestor : Elmt_Id :=
Next_Elmt
(First_Elmt
(Access_Disp_Table (Etype (Typ))));
Sec_DT_Typ : Elmt_Id :=
Next_Elmt
(First_Elmt
(Access_Disp_Table (Typ)));
procedure Copy_Secondary_DTs (Typ : Entity_Id);
-- Local procedure required to climb through the ancestors
-- and copy the contents of all their secondary dispatch
-- tables.
------------------------
-- Copy_Secondary_DTs --
------------------------
procedure Copy_Secondary_DTs (Typ : Entity_Id) is
E : Entity_Id;
Iface : Elmt_Id;
begin
-- Climb to the ancestor (if any) handling private types
if Present (Full_View (Etype (Typ))) then
if Full_View (Etype (Typ)) /= Typ then
Copy_Secondary_DTs (Full_View (Etype (Typ)));
end if;
if Present (Abstract_Interfaces (Typ)) elsif Etype (Typ) /= Typ then
and then not Is_Empty_Elmt_List Copy_Secondary_DTs (Etype (Typ));
(Abstract_Interfaces (Typ)) end if;
then
Iface := First_Elmt (Abstract_Interfaces (Typ));
E := First_Entity (Typ);
while Present (E)
and then Present (Node (Sec_DT_Ancestor))
loop
if Is_Tag (E) and then Chars (E) /= Name_uTag then
if not Is_Interface (Etype (Typ)) then
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Inherit_DT,
Args => New_List (
Node1 => Unchecked_Convert_To
(RTE (RE_Tag),
New_Reference_To
(Node (Sec_DT_Ancestor),
Loc)),
Node2 => Unchecked_Convert_To
(RTE (RE_Tag),
New_Reference_To
(Node (Sec_DT_Typ), Loc)),
Node3 => Make_Integer_Literal (Loc,
DT_Entry_Count (E)))));
end if;
Next_Elmt (Sec_DT_Ancestor); if Present (Abstract_Interfaces (Typ))
Next_Elmt (Sec_DT_Typ); and then not Is_Empty_Elmt_List
Next_Elmt (Iface); (Abstract_Interfaces (Typ))
end if; then
Iface := First_Elmt (Abstract_Interfaces (Typ));
E := First_Entity (Typ);
while Present (E)
and then Present (Node (Sec_DT_Ancestor))
loop
if Is_Tag (E) and then Chars (E) /= Name_uTag then
if not Is_Interface (Etype (Typ)) then
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Inherit_DT,
Args => New_List (
Node1 => Unchecked_Convert_To
(RTE (RE_Tag),
New_Reference_To
(Node (Sec_DT_Ancestor),
Loc)),
Node2 => Unchecked_Convert_To
(RTE (RE_Tag),
New_Reference_To
(Node (Sec_DT_Typ), Loc)),
Node3 => Make_Integer_Literal (Loc,
DT_Entry_Count (E)))));
end if;
Next_Elmt (Sec_DT_Ancestor);
Next_Elmt (Sec_DT_Typ);
Next_Elmt (Iface);
end if;
Next_Entity (E); Next_Entity (E);
end loop; end loop;
end if; end if;
end Copy_Secondary_DTs; end Copy_Secondary_DTs;
begin begin
if Present (Node (Sec_DT_Ancestor)) then if Present (Node (Sec_DT_Ancestor)) then
-- Handle private types -- Handle private types
if Present (Full_View (Typ)) then if Present (Full_View (Typ)) then
Copy_Secondary_DTs (Full_View (Typ)); Copy_Secondary_DTs (Full_View (Typ));
else else
Copy_Secondary_DTs (Typ); Copy_Secondary_DTs (Typ);
end if;
end if; end if;
end if; end;
end; end if;
end if; end if;
end if;
-- Generate: -- Generate:
-- Inherit_TSD (parent'tag, DT_Ptr); -- Inherit_TSD (parent'tag, DT_Ptr);
Append_To (Elab_Code, if not Is_Interface (Typ) then
Make_DT_Access_Action (Typ, Append_To (Elab_Code,
Action => Inherit_TSD, Make_DT_Access_Action (Typ,
Args => New_List ( Action => Inherit_TSD,
Node1 => Old_Tag2, Args => New_List (
Node2 => New_Reference_To (DT_Ptr, Loc)))); Node1 => Old_Tag2,
Node2 => New_Reference_To (DT_Ptr, Loc))));
end if;
end if;
if not Is_Interface (Typ) then if not Is_Interface (Typ) then
...@@ -3434,9 +3425,7 @@ package body Exp_Disp is ...@@ -3434,9 +3425,7 @@ package body Exp_Disp is
-- Ada 2005 (AI-251): Register the tag of the interfaces into -- Ada 2005 (AI-251): Register the tag of the interfaces into
-- the table of implemented interfaces. -- the table of implemented interfaces.
if not Is_Interface (Typ) if Num_Ifaces > 0 then
and then Num_Ifaces > 0
then
declare declare
Position : Int; Position : Int;
...@@ -3445,10 +3434,12 @@ package body Exp_Disp is ...@@ -3445,10 +3434,12 @@ package body Exp_Disp is
-- all its interfaces; otherwise this code is not needed because -- all its interfaces; otherwise this code is not needed because
-- Inherit_TSD has already inherited such interfaces. -- Inherit_TSD has already inherited such interfaces.
if Is_Interface (Etype (Typ)) then if Etype (Typ) /= Typ
and then Is_Interface (Etype (Typ))
then
Position := 1; Position := 1;
AI := First_Elmt (Abstract_Interfaces (Ancestor_Copy)); AI := First_Elmt (Ancestor_Ifaces);
while Present (AI) loop while Present (AI) loop
-- Generate: -- Generate:
-- Register_Interface (DT_Ptr, Interface'Tag); -- Register_Interface (DT_Ptr, Interface'Tag);
...@@ -3473,22 +3464,25 @@ package body Exp_Disp is ...@@ -3473,22 +3464,25 @@ package body Exp_Disp is
-- Register the interfaces that are not implemented by the -- Register the interfaces that are not implemented by the
-- ancestor -- ancestor
if Present (Abstract_Interfaces (Typ_Copy)) then AI := First_Elmt (Typ_Ifaces);
AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
-- Skip the interfaces implemented by the ancestor -- Skip the interfaces implemented by the ancestor
for Count in 1 .. Parent_Num_Ifaces loop for Count in 1 .. Parent_Num_Ifaces loop
Next_Elmt (AI); Next_Elmt (AI);
end loop; end loop;
-- Register the additional interfaces -- Register the additional interfaces
Position := Parent_Num_Ifaces + 1; Position := Parent_Num_Ifaces + 1;
while Present (AI) loop while Present (AI) loop
-- Generate:
-- Register_Interface (DT_Ptr, Interface'Tag);
-- Generate:
-- Register_Interface (DT_Ptr, Interface'Tag);
if not Is_Interface (Typ)
or else Typ /= Node (AI)
then
Append_To (Result, Append_To (Result,
Make_DT_Access_Action (Typ, Make_DT_Access_Action (Typ,
Action => Register_Interface_Tag, Action => Register_Interface_Tag,
...@@ -3502,9 +3496,10 @@ package body Exp_Disp is ...@@ -3502,9 +3496,10 @@ package body Exp_Disp is
Node3 => Make_Integer_Literal (Loc, Position)))); Node3 => Make_Integer_Literal (Loc, Position))));
Position := Position + 1; Position := Position + 1;
Next_Elmt (AI); end if;
end loop;
end if; Next_Elmt (AI);
end loop;
pragma Assert (Position = Num_Ifaces + 1); pragma Assert (Position = Num_Ifaces + 1);
end; end;
...@@ -3798,14 +3793,12 @@ package body Exp_Disp is ...@@ -3798,14 +3793,12 @@ package body Exp_Disp is
while Present (Prim_Elmt) loop while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt); Prim := Node (Prim_Elmt);
if Present (Abstract_Interface_Alias (Prim)) then if Present (Abstract_Interface_Alias (Prim))
and then Find_Dispatching_Type
(Abstract_Interface_Alias (Prim)) = Iface
then
Prim_Alias := Abstract_Interface_Alias (Prim); Prim_Alias := Abstract_Interface_Alias (Prim);
end if;
if Present (Prim_Alias)
and then Present (First_Entity (Prim_Alias))
and then Etype (First_Entity (Prim_Alias)) = Iface
then
-- Generate: -- Generate:
-- Ada.Tags.Set_Offset_Index (Tag (Iface_DT_Ptr), -- Ada.Tags.Set_Offset_Index (Tag (Iface_DT_Ptr),
-- Secondary_DT_Pos, Primary_DT_pos); -- Secondary_DT_Pos, Primary_DT_pos);
...@@ -3819,9 +3812,7 @@ package body Exp_Disp is ...@@ -3819,9 +3812,7 @@ package body Exp_Disp is
Make_Integer_Literal (Loc, Make_Integer_Literal (Loc,
DT_Position (Prim_Alias)), DT_Position (Prim_Alias)),
Make_Integer_Literal (Loc, Make_Integer_Literal (Loc,
DT_Position (Prim))))); DT_Position (Alias (Prim))))));
Prim_Alias := Empty;
end if; end if;
Next_Elmt (Prim_Elmt); Next_Elmt (Prim_Elmt);
...@@ -3909,7 +3900,11 @@ package body Exp_Disp is ...@@ -3909,7 +3900,11 @@ package body Exp_Disp is
Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Prim_Elmt) loop while Present (Prim_Elmt) loop
if not Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then Prim := Node (Prim_Elmt);
if not (Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim))
then
Nb_Prim := Nb_Prim + 1; Nb_Prim := Nb_Prim + 1;
end if; end if;
...@@ -3923,76 +3918,57 @@ package body Exp_Disp is ...@@ -3923,76 +3918,57 @@ package body Exp_Disp is
Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Prim_Elmt) loop while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt); Prim := Node (Prim_Elmt);
Prim_Pos := DT_Position (Prim);
if not Is_Predefined_Dispatching_Operation (Prim) then
pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
if Examined (UI_To_Int (Prim_Pos)) then
goto Continue;
else
Examined (UI_To_Int (Prim_Pos)) := True;
end if;
-- The current primitive overrides an interface-level -- Look for primitive overriding an abstract interface subprogram
-- subprogram
if Present (Abstract_Interface_Alias (Prim)) then if Present (Abstract_Interface_Alias (Prim))
and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
then
Prim_Pos := DT_Position (Alias (Prim));
pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
Examined (UI_To_Int (Prim_Pos)) := True;
-- Set the primitive operation kind regardless of subprogram -- Set the primitive operation kind regardless of subprogram
-- type. Generate: -- type. Generate:
-- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>); -- 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_Prim_Op_Kind,
Set_Prim_Op_Kind, Args => New_List (
Args => New_Reference_To (DT_Ptr, Loc),
New_List ( Make_Integer_Literal (Loc, Prim_Pos),
New_Reference_To (DT_Ptr, Loc), Prim_Op_Kind (Alias (Prim), Typ))));
Make_Integer_Literal (Loc, Prim_Pos),
Prim_Op_Kind (Prim, Typ))));
-- Retrieve the root of the alias chain if one is present -- Retrieve the root of the alias chain
if Present (Alias (Prim)) then Prim_Als := Prim;
Prim_Als := Prim; while Present (Alias (Prim_Als)) loop
while Present (Alias (Prim_Als)) loop Prim_Als := Alias (Prim_Als);
Prim_Als := Alias (Prim_Als); end loop;
end loop;
else
Prim_Als := Empty;
end if;
-- In the case of an entry wrapper, set the entry index -- In the case of an entry wrapper, set the entry index
if Ekind (Prim) = E_Procedure if Ekind (Prim) = E_Procedure
and then Present (Prim_Als) and then Is_Primitive_Wrapper (Prim_Als)
and then Is_Primitive_Wrapper (Prim_Als) and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry then
then -- Generate:
-- Ada.Tags.Set_Entry_Index
-- (DT_Ptr, <position>, <index>);
-- Generate: Append_To (Assignments,
-- Ada.Tags.Set_Entry_Index Make_DT_Access_Action (Typ,
-- (DT_Ptr, <position>, <index>); Action => Set_Entry_Index,
Args => New_List (
Append_To (Assignments, New_Reference_To (DT_Ptr, Loc),
Make_DT_Access_Action (Typ, Make_Integer_Literal (Loc, Prim_Pos),
Action => Make_Integer_Literal (Loc,
Set_Entry_Index, Find_Entry_Index
Args => (Wrapped_Entity (Prim_Als))))));
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;
<<Continue>>
Next_Elmt (Prim_Elmt); Next_Elmt (Prim_Elmt);
end loop; end loop;
end; end;
...@@ -4118,20 +4094,6 @@ package body Exp_Disp is ...@@ -4118,20 +4094,6 @@ package body Exp_Disp is
------------------------- -------------------------
procedure Set_All_DT_Position (Typ : Entity_Id) is procedure Set_All_DT_Position (Typ : Entity_Id) is
Parent_Typ : constant Entity_Id := Etype (Typ);
Root_Typ : constant Entity_Id := Root_Type (Typ);
First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
The_Tag : constant Entity_Id := First_Tag_Component (Typ);
Adjusted : Boolean := False;
Finalized : Boolean := False;
Count_Prim : Int;
DT_Length : Int;
Nb_Prim : Int;
Parent_EC : Int;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
procedure Validate_Position (Prim : Entity_Id); procedure Validate_Position (Prim : Entity_Id);
-- Check that the position assignated to Prim is completely safe -- Check that the position assignated to Prim is completely safe
...@@ -4143,31 +4105,50 @@ package body Exp_Disp is ...@@ -4143,31 +4105,50 @@ package body Exp_Disp is
----------------------- -----------------------
procedure Validate_Position (Prim : Entity_Id) is procedure Validate_Position (Prim : Entity_Id) is
Prim_Elmt : Elmt_Id; Op_Elmt : Elmt_Id;
Op : Entity_Id;
begin begin
Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); -- Aliased primitives are safe
while Present (Prim_Elmt)
and then Node (Prim_Elmt) /= Prim if Present (Alias (Prim)) then
loop return;
end if;
Op_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Op_Elmt) loop
Op := Node (Op_Elmt);
-- No need to check against itself
if Op = Prim then
null;
-- Primitive operations covering abstract interfaces are -- Primitive operations covering abstract interfaces are
-- allocated later -- allocated later
if Present (Abstract_Interface_Alias (Node (Prim_Elmt))) then elsif Present (Abstract_Interface_Alias (Op)) then
null; null;
-- Predefined dispatching operations are completely safe. They -- Predefined dispatching operations are completely safe. They
-- are allocated at fixed positions in a separate table. -- are allocated at fixed positions in a separate table.
elsif Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then elsif Is_Predefined_Dispatching_Operation (Op)
or else Is_Predefined_Dispatching_Alias (Op)
then
null; null;
-- Aliased subprograms are safe -- Aliased subprograms are safe
elsif Present (Alias (Prim)) then elsif Present (Alias (Op)) then
null; null;
elsif DT_Position (Node (Prim_Elmt)) = DT_Position (Prim) then elsif DT_Position (Op) = DT_Position (Prim)
and then not Is_Predefined_Dispatching_Operation (Op)
and then not Is_Predefined_Dispatching_Operation (Prim)
and then not Is_Predefined_Dispatching_Alias (Op)
and then not Is_Predefined_Dispatching_Alias (Prim)
then
-- Handle aliased subprograms -- Handle aliased subprograms
...@@ -4176,7 +4157,7 @@ package body Exp_Disp is ...@@ -4176,7 +4157,7 @@ package body Exp_Disp is
Op_2 : Entity_Id; Op_2 : Entity_Id;
begin begin
Op_1 := Node (Prim_Elmt); Op_1 := Op;
loop loop
if Present (Overridden_Operation (Op_1)) then if Present (Overridden_Operation (Op_1)) then
Op_1 := Overridden_Operation (Op_1); Op_1 := Overridden_Operation (Op_1);
...@@ -4204,10 +4185,27 @@ package body Exp_Disp is ...@@ -4204,10 +4185,27 @@ package body Exp_Disp is
end; end;
end if; end if;
Next_Elmt (Prim_Elmt); Next_Elmt (Op_Elmt);
end loop; end loop;
end Validate_Position; end Validate_Position;
-- Local variables
Parent_Typ : constant Entity_Id := Etype (Typ);
Root_Typ : constant Entity_Id := Root_Type (Typ);
First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
The_Tag : constant Entity_Id := First_Tag_Component (Typ);
Adjusted : Boolean := False;
Finalized : Boolean := False;
Count_Prim : Int;
DT_Length : Int;
Nb_Prim : Int;
Parent_EC : Int;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
-- Start of processing for Set_All_DT_Position -- Start of processing for Set_All_DT_Position
begin begin
...@@ -4225,7 +4223,7 @@ package body Exp_Disp is ...@@ -4225,7 +4223,7 @@ package body Exp_Disp is
-- C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable -- C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable
-- give a coherent set of information -- give a coherent set of information
if Is_CPP_Class (Root_Typ) then if Is_CPP_Class (Root_Typ) and then Debug_Flag_QQ then
-- Compute the number of primitive operations in the main Vtable -- Compute the number of primitive operations in the main Vtable
-- Set their position: -- Set their position:
...@@ -4356,21 +4354,28 @@ package body Exp_Disp is ...@@ -4356,21 +4354,28 @@ package body Exp_Disp is
Prim_Elmt := First_Prim; Prim_Elmt := First_Prim;
Count_Prim := 0; Count_Prim := 0;
while Present (Prim_Elmt) loop while Present (Prim_Elmt) loop
Count_Prim := Count_Prim + 1; Prim := Node (Prim_Elmt);
Prim := Node (Prim_Elmt);
-- Predefined primitives have a separate dispatch table
if not (Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim))
then
Count_Prim := Count_Prim + 1;
end if;
-- Ada 2005 (AI-251) -- Ada 2005 (AI-251)
if Present (Abstract_Interface_Alias (Prim)) if Present (Abstract_Interface_Alias (Prim))
and then Is_Interface (Scope (DTC_Entity and then Is_Interface
(Abstract_Interface_Alias (Prim)))) (Find_Dispatching_Type
(Abstract_Interface_Alias (Prim)))
then then
Set_DTC_Entity (Prim, Set_DTC_Entity (Prim,
Find_Interface_Tag Find_Interface_Tag
(T => Typ, (T => Typ,
Iface => Scope (DTC_Entity Iface => Find_Dispatching_Type
(Abstract_Interface_Alias (Prim))))); (Abstract_Interface_Alias (Prim))));
else else
Set_DTC_Entity (Prim, The_Tag); Set_DTC_Entity (Prim, The_Tag);
end if; end if;
...@@ -4385,11 +4390,27 @@ package body Exp_Disp is ...@@ -4385,11 +4390,27 @@ package body Exp_Disp is
end loop; end loop;
declare declare
Fixed_Prim : array (Int range 0 .. Parent_EC + Count_Prim) Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean
of Boolean := (others => False); := (others => False);
E : Entity_Id; E : Entity_Id;
procedure Set_Fixed_Prim (Pos : Int);
-- Sets to true an element of the Fixed_Prim table to indicate
-- that this entry of the dispatch table of Typ is occupied.
--------------------
-- Set_Fixed_Prim --
--------------------
procedure Set_Fixed_Prim (Pos : Int) is
begin
pragma Assert (Pos >= 0 and then Pos <= Count_Prim);
Fixed_Prim (Pos) := True;
exception
when Constraint_Error =>
raise Program_Error;
end Set_Fixed_Prim;
begin begin
-- Second stage: Register fixed entries -- Second stage: Register fixed entries
...@@ -4399,64 +4420,56 @@ package body Exp_Disp is ...@@ -4399,64 +4420,56 @@ package body Exp_Disp is
Prim := Node (Prim_Elmt); Prim := Node (Prim_Elmt);
-- Predefined primitives have a separate table and all its -- Predefined primitives have a separate table and all its
-- entries are at predefined fixed positions -- 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));
-- Overriding interface primitives of an ancestor elsif Is_Predefined_Dispatching_Alias (Prim) then
E := Alias (Prim);
elsif DT_Position (Prim) = No_Uint while Present (Alias (E)) loop
and then Present (Abstract_Interface_Alias (Prim)) E := Alias (E);
and then Present (DTC_Entity end loop;
(Abstract_Interface_Alias (Prim)))
and then DT_Position (Abstract_Interface_Alias (Prim)) Set_DT_Position (Prim, Default_Prim_Op_Position (E));
/= No_Uint
and then Is_Inherited_Operation (Prim) -- Overriding primitives of ancestor abstract interfaces
and then Is_Ancestor (Scope
(DTC_Entity elsif Present (Abstract_Interface_Alias (Prim))
(Abstract_Interface_Alias (Prim))), and then Is_Ancestor
Typ) (Find_Dispatching_Type
(Abstract_Interface_Alias (Prim)),
Typ)
then then
Set_DT_Position (Prim, pragma Assert (DT_Position (Prim) = No_Uint
DT_Position (Abstract_Interface_Alias (Prim))); and then Present (DTC_Entity
Set_DT_Position (Alias (Prim), (Abstract_Interface_Alias (Prim))));
DT_Position (Abstract_Interface_Alias (Prim)));
Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True; E := Abstract_Interface_Alias (Prim);
Set_DT_Position (Prim, DT_Position (E));
pragma Assert
(DT_Position (Alias (Prim)) = No_Uint
or else DT_Position (Alias (Prim)) = DT_Position (E));
Set_DT_Position (Alias (Prim), DT_Position (E));
Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
-- Overriding primitives must use the same entry as the -- Overriding primitives must use the same entry as the
-- overriden primitive -- overriden primitive
elsif DT_Position (Prim) = No_Uint elsif not Present (Abstract_Interface_Alias (Prim))
and then Present (Alias (Prim)) and then Present (Alias (Prim))
and then Find_Dispatching_Type (Alias (Prim)) /= Typ
and then Is_Ancestor
(Find_Dispatching_Type (Alias (Prim)), Typ)
and then Present (DTC_Entity (Alias (Prim))) and then Present (DTC_Entity (Alias (Prim)))
and then DT_Position (Alias (Prim)) /= No_Uint
and then Is_Inherited_Operation (Prim)
and then Is_Ancestor (Scope (DTC_Entity (Alias (Prim))), Typ)
then then
E := Alias (Prim); E := Alias (Prim);
while not (Present (DTC_Entity (E))
or else DT_Position (E) = No_Uint)
and then Present (Alias (E))
loop
E := Alias (E);
end loop;
pragma Assert (Present (DTC_Entity (E))
and then
DT_Position (E) /= No_Uint);
Set_DT_Position (Prim, DT_Position (E)); Set_DT_Position (Prim, DT_Position (E));
Fixed_Prim (UI_To_Int (DT_Position (E))) := True;
-- If this is not the last element in the chain continue
-- traversing the chain. This is required to properly
-- handling renamed primitives
while Present (Alias (E)) loop if not Is_Predefined_Dispatching_Alias (E) then
E := Alias (E); Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
Fixed_Prim (UI_To_Int (DT_Position (E))) := True; end if;
end loop;
end if; end if;
Next_Elmt (Prim_Elmt); Next_Elmt (Prim_Elmt);
...@@ -4472,17 +4485,10 @@ package body Exp_Disp is ...@@ -4472,17 +4485,10 @@ package body Exp_Disp is
-- Skip primitives previously set entries -- Skip primitives previously set entries
if Is_Predefined_Dispatching_Operation (Prim) then if DT_Position (Prim) /= No_Uint then
null;
elsif DT_Position (Prim) /= No_Uint then
null;
elsif Etype (DTC_Entity (Prim)) /= RTE (RE_Tag) then
null; null;
-- Primitives covering interface primitives are -- Primitives covering interface primitives are handled later
-- handled later
elsif Present (Abstract_Interface_Alias (Prim)) then elsif Present (Abstract_Interface_Alias (Prim)) then
null; null;
...@@ -4492,11 +4498,12 @@ package body Exp_Disp is ...@@ -4492,11 +4498,12 @@ package body Exp_Disp is
loop loop
Nb_Prim := Nb_Prim + 1; Nb_Prim := Nb_Prim + 1;
pragma Assert (Nb_Prim <= Count_Prim);
exit when not Fixed_Prim (Nb_Prim); exit when not Fixed_Prim (Nb_Prim);
end loop; end loop;
Set_DT_Position (Prim, UI_From_Int (Nb_Prim)); Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
Fixed_Prim (Nb_Prim) := True; Set_Fixed_Prim (Nb_Prim);
end if; end if;
Next_Elmt (Prim_Elmt); Next_Elmt (Prim_Elmt);
...@@ -4512,12 +4519,16 @@ package body Exp_Disp is ...@@ -4512,12 +4519,16 @@ package body Exp_Disp is
Prim := Node (Prim_Elmt); Prim := Node (Prim_Elmt);
if DT_Position (Prim) = No_Uint if DT_Position (Prim) = No_Uint
and then Present (Abstract_Interface_Alias (Prim)) and then Present (Abstract_Interface_Alias (Prim))
then then
pragma Assert (Present (Alias (Prim))
and then Find_Dispatching_Type (Alias (Prim)) = Typ);
-- Check if this entry will be placed in the primary DT -- Check if this entry will be placed in the primary DT
if Etype (DTC_Entity (Abstract_Interface_Alias (Prim))) if Is_Ancestor (Find_Dispatching_Type
= RTE (RE_Tag) (Abstract_Interface_Alias (Prim)),
Typ)
then then
pragma Assert (DT_Position (Alias (Prim)) /= No_Uint); pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
Set_DT_Position (Prim, DT_Position (Alias (Prim))); Set_DT_Position (Prim, DT_Position (Alias (Prim)));
...@@ -4527,9 +4538,8 @@ package body Exp_Disp is ...@@ -4527,9 +4538,8 @@ package body Exp_Disp is
else else
pragma Assert pragma Assert
(DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint); (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint);
Set_DT_Position (Prim, Set_DT_Position (Prim,
DT_Position (Abstract_Interface_Alias (Prim))); DT_Position (Abstract_Interface_Alias (Prim)));
end if; end if;
end if; end if;
...@@ -4562,7 +4572,8 @@ package body Exp_Disp is ...@@ -4562,7 +4572,8 @@ package body Exp_Disp is
-- Calculate real size of the dispatch table -- Calculate real size of the dispatch table
if not Is_Predefined_Dispatching_Operation (Prim) if not (Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim))
and then UI_To_Int (DT_Position (Prim)) > DT_Length and then UI_To_Int (DT_Position (Prim)) > DT_Length
then then
DT_Length := UI_To_Int (DT_Position (Prim)); DT_Length := UI_To_Int (DT_Position (Prim));
...@@ -4571,7 +4582,9 @@ package body Exp_Disp is ...@@ -4571,7 +4582,9 @@ package body Exp_Disp is
-- Ensure that the asignated position to non-predefined -- Ensure that the asignated position to non-predefined
-- dispatching operations in the dispatch table is correct. -- dispatching operations in the dispatch table is correct.
if not Is_Predefined_Dispatching_Operation (Prim) then if not (Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim))
then
Validate_Position (Prim); Validate_Position (Prim);
end if; end if;
...@@ -4587,12 +4600,16 @@ package body Exp_Disp is ...@@ -4587,12 +4600,16 @@ package body Exp_Disp is
-- for a visible abstract type, because it could never be over- -- for a visible abstract type, because it could never be over-
-- ridden. For explicit declarations this is checked at the -- ridden. For explicit declarations this is checked at the
-- point of declaration, but for inherited operations it must -- point of declaration, but for inherited operations it must
-- be done when building the dispatch table. Input is excluded -- be done when building the dispatch table.
-- because
-- Ada 2005 (AI-251): Hidden entities associated with abstract
-- interface primitives are not taken into account because the
-- check is done with the aliased primitive.
if Is_Abstract (Typ) if Is_Abstract (Typ)
and then Is_Abstract (Prim) and then Is_Abstract (Prim)
and then Present (Alias (Prim)) and then Present (Alias (Prim))
and then not Present (Abstract_Interface_Alias (Prim))
and then Is_Derived_Type (Typ) and then Is_Derived_Type (Typ)
and then In_Private_Part (Current_Scope) and then In_Private_Part (Current_Scope)
and then and then
...@@ -4847,6 +4864,14 @@ package body Exp_Disp is ...@@ -4847,6 +4864,14 @@ package body Exp_Disp is
if Is_Abstract (Prim) then if Is_Abstract (Prim) then
Write_Str (" is abstract;"); Write_Str (" is abstract;");
-- Check if this is a null primitive
elsif Comes_From_Source (Prim)
and then Ekind (Prim) = E_Procedure
and then Null_Present (Parent (Prim))
then
Write_Str (" is null;");
end if; end if;
Write_Eol; Write_Eol;
......
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