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