mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-22 03:30:29 +08:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Javier Miranda 2006-10-31 18:50:11 +01:00 committed by Arnaud Charlet
parent 3cb8344bd3
commit bfef8d0d62
3 changed files with 757 additions and 635 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

154
gcc/ada/a-tags.adb
View File

@ -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;
-------------------------

27
gcc/ada/a-tags.ads
View File

@ -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,14 +73,13 @@ package Ada.Tags is
function Parent_Tag (T : Tag) return Tag;
pragma Ada_05 (Parent_Tag);
type Tag_Array is array (Positive range <>) of Tag;
function Interface_Ancestor_Tags (T : Tag) return Tag_Array;
pragma Ada_05 (Interface_Ancestor_Tags);
Tag_Error : exception;
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);
private
-- The following subprogram specifications are placed here instead of
-- the package body to see them from the frontend through rtsfind.
@ -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

1211
gcc/ada/exp_disp.adb
View File

File diff suppressed because it is too large Load Diff