OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

a-tags.ads, a-tags.adb (Tag_Size): This constant is now internal to the package. 

2007-04-20  Javier Miranda  <miranda@adacore.com>

	* a-tags.ads, a-tags.adb (Tag_Size): This constant is now internal to
	the package.
	(Object_Specific_Data_Array): This is now internal to the package.
	(Object_Specific_Data): This is now internal to the package.
	(Select_Specific_Data_Element): This is now internal to the package.
	(Select_Specific_Data_Array): This is now internal to the package.
	(Select_Specific_Data): This is now internal to the package.
	(Offset_To_Top_Function_Ptr): This is now public.
	(To_Offset_To_Top_Function_Ptr): Removed.
	(Storage_Offset_Ptr,To_Storage_Offset_Ptr): These declarations are now
	 local to subprogram Offset_To_Top.
	(Predefined_DT): Removed.
	(Typeinfo_Ptr): Removed.
	(OSD): This function is now internal to this package.
	(SSD): This function is now internal to this package.
	(DT): New function that displaces the pointer to the table of primitives
	 to get access to the enclosing wrapper record.
	(IW_Membership): Code cleanup.
	(Offset_To_Top): Code cleanup.
	(Predefined_DT): Removed.
	(Register_Interface_Tag): Removed.
	(Set_Interface_Table): Removed.
	(Set_Offset_Index): Removed.
	(Set_Offset_To_Top): Code cleanup.
	(Set_OSD): Removed.
	(Set_Signature): Removed.
	(Set_SSD): Removed.
	(Set_Tagged_Kind): Removed.
	(Typeinfo_Ptr): Removed.
	(TSD): Removed.
	(Displace): Add missing check on null actual.

	* exp_disp.ads, exp_disp.adb
	(Select_Expansion_Utilities): Removed.
	(Build_Common_Dispatching_Select_Statements): Moved to exp_atags.
	(Expand_Dispatching_Call): Update calls to Get_Prim_Op_Address because
	the interface requires a new parameter.
	(Make_Disp_Asynchronous_Select_Spec, Make_Disp_Conditional_Select_Spec,
	Make_Disp_Get_Prim_Op_Kind_Spec, Make_Disp_Timed_Select_Spec): Replace
	calls to subprograms Build_T, Build_S, etc. by the corresponding code.
	Done to remove package Select_Expansion_Utilities.
	(Make_DT): New implementation for statically allocated dispatch tables.
	(Make_Secondary_DT): Moved to the scope of Make_DT.
	(Register_Primitive): Code cleanup plus incoporate the use of the new
	function DT_Address_Attribute.
	(Expand_Interface_Thunk): The profile of this subprogram has been
	changed to return the Thunk_Id and the corresponding code.
	(Fill_DT_Entry): Removed. Its functionality is now provided by
	subprogram Register_Primitive.
	(Fill_Secondary_DT_Entry): Removed. Its functionality is now provided by
	subprogram Register_Primitive.
	(Register_Primitive): New subprogram that incorporates the previous
	functionalities of Fill_DT_Entry and Fill_Secondary_DT_Entry.
	(Build_Common_Dispatching_Select_Statements): Remove formal Typ. This
	was only required to call Make_DT_Access_Action, which is now removed.
	(Ada_Actions): Removed
	(Action_Is_Proc): Removed
	(Action_Nb_Arg): Removed
	Replace all the calls to Make_DT_Access_Action by direct calls to
	Make_Procedure_Call_Statement or Make_Function_Call.
	(Set_DTC_Entity_Value): New subprogram.
	(Set_All_DT_Position): Add call to new subprogram Set_DTC_Entity_Value.
	(Expand_Interface_Thunk): Add missing support for primitives that are
	functions with a controlling result (case in which there is no need
	to generate the thunk).

	* exp_atag.ads, exp_atag.adb
	(Build_DT): New subprogram that displaces the pointer to reference the
	base of the wrapper record.
	(Build_Typeinfo_Offset): Removed.
	(RTE_Tag_Node): Removed.
	(Build_Common_Dispatching_Select_Statements): Moved here from exp_disp
	(Build_Get_RC_Offset): Removed.
	(Build_Inherit_Predefined_Prims): Removed.
	(Build_Inherit_TSD: Removed.
	(Build_New_TSD): Removed.
	(Build_Set_External_Tag): Removed.
	(Build_Set_Predefined_Prim_Op_Address): Add documentation.
	(Build_Set_Prim_Op_Address): Add documentation.
	(Build_Set_TSD): Removed.

	* rtsfind.ads, rtsfind.adb
	(Load_Fail): If load fails and we are not in configurable run-time
	mode, then raise Unrecoverable_Error.
	(Text_IO_Kludge): Generate an error message if a run-time library is
	not available in a given run-time (ie. zfp run-time).
	(RTE_Record_Component): Add code to check that the component we search
	for is not found in two records in the given run-time package.
	(RE_DT_Offset_To_Top_Size, RE_DT_Predef_Prims_Size): Removed
	(RE_DT_Predef_Prims_Offset): New entity
	(RE_Static_Offset_To_Top): New entity
	(RE_HT_Link): New entity.
	(System_Address_Image): Addition of this run-time package.
	(RE_Address_Image): New entity.
	(RE_Abstract_Interface): Removed.
	(RE_Default_Prim_Op_Count): Removed.
	(RE_DT_Entry_Size): Removed.
	(RE_DT_Min_Prologue_Size): Removed.
	(RE_DT_Prologue_Size): Removed.
	(RE_Ifaces_Table_Ptr): Removed.
	(RE_Interface_Data_Ptr): Removed.
	(RE_Type_Specific_Data): Removed.
	(RE_Primary_DT): Removed.
	(RE_Register_Interface_Tag): Removed.
	(RE_Set_Offset_Index): Removed.
	(RE_Set_OSD): Removed.
	(RE_Set_SSD): Removed.
	(RE_Set_Signature): Removed.
	(RE_Set_Tagged_Kind): Removed.
	(RE_Address_Array): New entity.
	(RE_DT): New entity.
	(RE_Iface_Tag): New entity.
	(RE_Interfaces_Table): New entity.
	(RE_No_Dispatch_Table): New entity.
	(RE_NDT_Prims_Ptr): New entity.
	(RE_NDT_TSD): New entity.
	(RE_Num_Prims): New entity.
	(RE_Offset_To_Top_Function_Ptr): New entity.
	(RE_OSD_Table): New entity.
	(RE_OSD_Num_Prims): New entity.
	(RE_Predef_Prims): New entity
	(RE_Predef_Prims_Table_Ptr): New entity.
	(RE_Primary_DT): New entity.
	(RE_Signature): New entity.
	(RE_SSD): New entity.
	(RE_TSD): New entity.
	(RE_Type_Specific_Data): New entity.
	(RE_Tag_Kind): New entity.

From-SVN: r125379
This commit is contained in:
Javier Miranda 2007-06-06 12:20:45 +02:00 committed by Arnaud Charlet
parent dc1f64ac92
commit d0dd5209d9
8 changed files with 3610 additions and 3087 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -41,32 +41,40 @@ pragma Elaborate_All (System.HTable);
package body Ada.Tags is
-- Object specific data types (see description in a-tags.ads)
-----------------------
-- Local Subprograms --
-----------------------
type Object_Specific_Data_Array is array (Positive range <>) of Positive;
function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
-- Given the tag of an object and the tag associated to a type, return
-- true if Obj is in Typ'Class.
type Object_Specific_Data (Nb_Prim : Positive) is record
OSD_Table : Object_Specific_Data_Array (1 .. Nb_Prim);
-- Table used in secondary DT to reference their counterpart in the
-- select specific data (in the TSD of the primary DT). This construct
-- is used in the handling of dispatching triggers in select statements.
-- Nb_Prim is the number of non-predefined primitive operations.
end record;
function Get_External_Tag (T : Tag) return System.Address;
-- Returns address of a null terminated string containing the external name
-- Select specific data types
function Is_Primary_DT (T : Tag) return Boolean;
-- Given a tag returns True if it has the signature of a primary dispatch
-- table. This is Inline_Always since it is called from other Inline_
-- Always subprograms where we want no out of line code to be generated.
type Select_Specific_Data_Element is record
Index : Positive;
Kind : Prim_Op_Kind;
end record;
function Length (Str : Cstring_Ptr) return Natural;
-- Length of string represented by the given pointer (treating the string
-- as a C-style string, which is Nul terminated).
type Select_Specific_Data_Array is
array (Positive range <>) of Select_Specific_Data_Element;
function OSD (T : Tag) return Object_Specific_Data_Ptr;
-- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table,
-- retrieve the address of the record containing the Object Specific
-- Data table.
type Select_Specific_Data (Nb_Prim : Positive) is record
SSD_Table : Select_Specific_Data_Array (1 .. Nb_Prim);
-- NOTE: Nb_Prim is the number of non-predefined primitive operations
end record;
function SSD (T : Tag) return Select_Specific_Data_Ptr;
-- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, retrieves the
-- address of the record containing the Select Specific Data in T's TSD.
pragma Inline_Always (CW_Membership);
pragma Inline_Always (Get_External_Tag);
pragma Inline_Always (Is_Primary_DT);
pragma Inline_Always (OSD);
pragma Inline_Always (SSD);
---------------------------------------------
-- Unchecked Conversions for String Fields --
@ -78,6 +86,17 @@ package body Ada.Tags is
function To_Cstring_Ptr is
new Unchecked_Conversion (System.Address, Cstring_Ptr);
-- Disable warnings on possible aliasing problem because we only use
-- use this function to convert tags found in the External_Tag of
-- locally defined tagged types.
pragma Warnings (off);
function To_Tag is
new Unchecked_Conversion (Integer_Address, Tag);
pragma Warnings (on);
------------------------------------------------
-- Unchecked Conversions for other components --
------------------------------------------------
@ -88,47 +107,93 @@ package body Ada.Tags is
function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size);
-- The profile of the implicitly defined _size primitive
type Offset_To_Top_Function_Ptr is
access function (This : System.Address)
return System.Storage_Elements.Storage_Offset;
-- Type definition used to call the function that is generated by the
-- expander in case of tagged types with discriminants that have secondary
-- dispatch tables. This function provides the Offset_To_Top value in this
-- specific case.
-------------------------------
-- Inline_Always Subprograms --
-------------------------------
function To_Offset_To_Top_Function_Ptr is
new Unchecked_Conversion (System.Address, Offset_To_Top_Function_Ptr);
-- Inline_always subprograms must be placed before their first call to
-- avoid defeating the frontend inlining mechanism and thus ensure the
-- generation of their correct debug info.
type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset;
-------------------
-- CW_Membership --
-------------------
function To_Storage_Offset_Ptr is
new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
-- Canonical implementation of Classwide Membership corresponding to:
-----------------------
-- Local Subprograms --
-----------------------
-- Obj in Typ'Class
function Is_Primary_DT (T : Tag) return Boolean;
pragma Inline_Always (Is_Primary_DT);
-- Given a tag returns True if it has the signature of a primary dispatch
-- table. This is Inline_Always since it is called from other Inline_
-- Always subprograms where we want no out of line code to be generated.
-- Each dispatch table contains a reference to a table of ancestors (stored
-- in the first part of the Tags_Table) and a count of the level of
-- inheritance "Idepth".
function Length (Str : Cstring_Ptr) return Natural;
-- Length of string represented by the given pointer (treating the string
-- as a C-style string, which is Nul terminated).
-- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
-- contained in the dispatch table referenced by Obj'Tag . Knowing the
-- level of inheritance of both types, this can be computed in constant
-- time by the formula:
function Predefined_DT (T : Tag) return Tag;
pragma Inline_Always (Predefined_DT);
-- Displace the Tag to reference the dispatch table containing the
-- predefined primitives.
-- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
-- = Typ'tag
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.
function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
Obj_TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (Obj_Tag) - DT_Typeinfo_Ptr_Size);
Typ_TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (Typ_Tag) - DT_Typeinfo_Ptr_Size);
Obj_TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (Obj_TSD_Ptr.all);
Typ_TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (Typ_TSD_Ptr.all);
Pos : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth;
begin
return Pos >= 0 and then Obj_TSD.Tags_Table (Pos) = Typ_Tag;
end CW_Membership;
pragma Unreferenced (Typeinfo_Ptr);
-- These functions will be used for full compatibility with the C++ ABI
----------------------
-- Get_External_Tag --
----------------------
function Get_External_Tag (T : Tag) return System.Address is
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
begin
return To_Address (TSD.External_Tag);
end Get_External_Tag;
-------------------
-- Is_Primary_DT --
-------------------
function Is_Primary_DT (T : Tag) return Boolean is
begin
return DT (T).Signature = Primary_DT;
end Is_Primary_DT;
---------
-- OSD --
---------
function OSD (T : Tag) return Object_Specific_Data_Ptr is
OSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
begin
return To_Object_Specific_Data_Ptr (OSD_Ptr.all);
end OSD;
---------
-- SSD --
---------
function SSD (T : Tag) return Select_Specific_Data_Ptr is
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
begin
return TSD.SSD;
end SSD;
-------------------------
-- External_Tag_HTable --
@ -192,8 +257,12 @@ package body Ada.Tags is
-----------------
function Get_HT_Link (T : Tag) return Tag is
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
begin
return TSD (T).HT_Link;
return TSD.HT_Link;
end Get_HT_Link;
----------
@ -213,39 +282,16 @@ package body Ada.Tags is
-----------------
procedure Set_HT_Link (T : Tag; Next : Tag) is
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
begin
TSD (T).HT_Link := Next;
TSD.HT_Link := Next;
end Set_HT_Link;
end HTable_Subprograms;
-------------------
-- CW_Membership --
-------------------
-- Canonical implementation of Classwide Membership corresponding to:
-- Obj in Typ'Class
-- Each dispatch table contains a reference to a table of ancestors (stored
-- in the first part of the Tags_Table) and a count of the level of
-- inheritance "Idepth".
-- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
-- contained in the dispatch table referenced by Obj'Tag . Knowing the
-- level of inheritance of both types, this can be computed in constant
-- time by the formula:
-- 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
Pos : Integer;
begin
Pos := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
return Pos >= 0 and then TSD (Obj_Tag).Tags_Table (Pos) = Typ_Tag;
end CW_Membership;
------------------
-- Base_Address --
------------------
@ -265,14 +311,18 @@ package body Ada.Tags is
is
Iface_Table : Interface_Data_Ptr;
Obj_Base : System.Address;
Obj_DT : Tag;
Obj_TSD : Type_Specific_Data_Ptr;
Obj_DT : Dispatch_Table_Ptr;
Obj_DT_Tag : Tag;
begin
Obj_Base := This - Offset_To_Top (This);
Obj_DT := To_Tag_Ptr (Obj_Base).all;
Obj_TSD := TSD (Obj_DT);
Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
if System."=" (This, System.Null_Address) then
return System.Null_Address;
end if;
Obj_Base := Base_Address (This);
Obj_DT_Tag := To_Tag_Ptr (Obj_Base).all;
Obj_DT := DT (To_Tag_Ptr (Obj_Base).all);
Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table;
if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop
@ -288,14 +338,11 @@ package body Ada.Tags is
-- to provide us with this value
else
Obj_Base :=
Obj_Base +
To_Offset_To_Top_Function_Ptr
(Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func).all
(Obj_Base);
Obj_Base := Obj_Base +
Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func.all
(Obj_Base);
end if;
Obj_DT := To_Tag_Ptr (Obj_Base).all;
return Obj_Base;
end if;
end loop;
@ -304,7 +351,7 @@ package body Ada.Tags is
-- 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
if CW_Membership (Obj_DT_Tag, T) then
return Obj_Base;
end if;
@ -313,6 +360,17 @@ package body Ada.Tags is
raise Constraint_Error;
end Displace;
--------
-- DT --
--------
function DT (T : Tag) return Dispatch_Table_Ptr is
Offset : constant SSE.Storage_Offset :=
To_Dispatch_Table_Ptr (T).Prims_Ptr'Position;
begin
return To_Dispatch_Table_Ptr (To_Address (T) - Offset);
end DT;
-------------------
-- IW_Membership --
-------------------
@ -329,20 +387,15 @@ package body Ada.Tags is
function IW_Membership (This : System.Address; T : Tag) return Boolean is
Iface_Table : Interface_Data_Ptr;
Last_Id : Natural;
Obj_Base : System.Address;
Obj_DT : Tag;
Obj_DT : Dispatch_Table_Ptr;
Obj_TSD : Type_Specific_Data_Ptr;
begin
Obj_Base := This - Offset_To_Top (This);
Obj_DT := To_Tag_Ptr (Obj_Base).all;
Obj_TSD := TSD (Obj_DT);
Last_Id := Obj_TSD.Idepth;
-- Look for the tag in the table of interfaces
Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
Obj_Base := Base_Address (This);
Obj_DT := DT (To_Tag_Ptr (Obj_Base).all);
Obj_TSD := To_Type_Specific_Data_Ptr (Obj_DT.TSD);
Iface_Table := Obj_TSD.Interfaces_Table;
if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop
@ -355,7 +408,7 @@ package body Ada.Tags is
-- Look for the tag in the ancestor tags table. This is required for:
-- Iface_CW in Typ'Class
for Id in 0 .. Last_Id loop
for Id in 0 .. Obj_TSD.Idepth loop
if Obj_TSD.Tags_Table (Id) = T then
return True;
end if;
@ -384,14 +437,18 @@ package body Ada.Tags is
-------------------
function Expanded_Name (T : Tag) return String is
Result : Cstring_Ptr;
Result : Cstring_Ptr;
TSD_Ptr : Addr_Ptr;
TSD : Type_Specific_Data_Ptr;
begin
if T = No_Tag then
raise Tag_Error;
end if;
Result := TSD (T).Expanded_Name;
TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
Result := TSD.Expanded_Name;
return Result (1 .. Length (Result));
end Expanded_Name;
@ -400,14 +457,18 @@ package body Ada.Tags is
------------------
function External_Tag (T : Tag) return String is
Result : Cstring_Ptr;
Result : Cstring_Ptr;
TSD_Ptr : Addr_Ptr;
TSD : Type_Specific_Data_Ptr;
begin
if T = No_Tag then
raise Tag_Error;
end if;
Result := TSD (T).External_Tag;
TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
Result := TSD.External_Tag;
return Result (1 .. Length (Result));
end External_Tag;
@ -420,15 +481,6 @@ package body Ada.Tags is
return SSD (T).SSD_Table (Position).Index;
end Get_Entry_Index;
----------------------
-- Get_External_Tag --
----------------------
function Get_External_Tag (T : Tag) return System.Address is
begin
return To_Address (TSD (T).External_Tag);
end Get_External_Tag;
----------------------
-- Get_Prim_Op_Kind --
----------------------
@ -462,8 +514,12 @@ package body Ada.Tags is
-------------------
function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
begin
return TSD (T).RC_Offset;
return TSD.RC_Offset;
end Get_RC_Offset;
---------------------
@ -471,10 +527,8 @@ package body Ada.Tags is
---------------------
function Get_Tagged_Kind (T : Tag) return Tagged_Kind is
Tagged_Kind_Ptr : constant System.Address :=
To_Address (T) - K_Tagged_Kind;
begin
return To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all;
return DT (T).Tag_Kind;
end Get_Tagged_Kind;
-----------------------------
@ -482,11 +536,13 @@ package body Ada.Tags is
-----------------------------
function Interface_Ancestor_Tags (T : Tag) return Tag_Array is
Iface_Table : Interface_Data_Ptr;
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
Iface_Table : constant Interface_Data_Ptr := TSD.Interfaces_Table;
begin
Iface_Table := To_Interface_Data_Ptr (TSD (T).Ifaces_Table_Ptr);
if Iface_Table = null then
declare
Table : Tag_Array (1 .. 0);
@ -510,17 +566,67 @@ package body Ada.Tags is
-- Internal_Tag --
------------------
-- Internal tags have the following format:
-- "Internal tag at 16#ADDRESS#: <full-name-of-tagged-type>"
Internal_Tag_Header : constant String := "Internal tag at ";
Header_Separator : constant Character := '#';
function Internal_Tag (External : String) return Tag is
Ext_Copy : aliased String (External'First .. External'Last + 1);
Res : Tag;
Res : Tag := null;
begin
-- Make a copy of the string representing the external tag with
-- a null at the end.
-- Handle locally defined tagged types
Ext_Copy (External'Range) := External;
Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
Res := External_Tag_HTable.Get (Ext_Copy'Address);
if External'Length > Internal_Tag_Header'Length
and then
External (External'First ..
External'First + Internal_Tag_Header'Length - 1)
= Internal_Tag_Header
then
declare
Addr_First : constant Natural :=
External'First + Internal_Tag_Header'Length;
Addr_Last : Natural;
Addr : Integer_Address;
begin
-- Search the second separator (#) to identify the address
Addr_Last := Addr_First;
for J in 1 .. 2 loop
while Addr_Last <= External'Last
and then External (Addr_Last) /= Header_Separator
loop
Addr_Last := Addr_Last + 1;
end loop;
-- Skip the first separator
if J = 1 then
Addr_Last := Addr_Last + 1;
end if;
end loop;
if Addr_Last <= External'Last then
Addr :=
Integer_Address'Value (External (Addr_First .. Addr_Last));
return To_Tag (Addr);
end if;
end;
-- Handle library-level tagged types
else
-- Make a copy of the string representing the external tag with
-- a null at the end.
Ext_Copy (External'Range) := External;
Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
Res := External_Tag_HTable.Get (Ext_Copy'Address);
end if;
if Res = null then
declare
@ -546,32 +652,30 @@ package body Ada.Tags is
(Descendant : Tag;
Ancestor : Tag) return Boolean
is
D_TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (Descendant)
- DT_Typeinfo_Ptr_Size);
A_TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size);
D_TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (D_TSD_Ptr.all);
A_TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (A_TSD_Ptr.all);
begin
return CW_Membership (Descendant, Ancestor)
and then TSD (Descendant).Access_Level = TSD (Ancestor).Access_Level;
and then D_TSD.Access_Level = A_TSD.Access_Level;
end Is_Descendant_At_Same_Level;
-------------------
-- Is_Primary_DT --
-------------------
function Is_Primary_DT (T : Tag) return Boolean is
Signature : constant Storage_Offset_Ptr :=
To_Storage_Offset_Ptr (To_Address (T) - K_Signature);
Sig_Values : constant Signature_Values :=
To_Signature_Values (Signature.all);
begin
return Sig_Values (2) = Primary_DT;
end Is_Primary_DT;
------------
-- Length --
------------
function Length (Str : Cstring_Ptr) return Natural is
Len : Integer := 1;
Len : Integer;
begin
Len := 1;
while Str (Len) /= ASCII.Nul loop
Len := Len + 1;
end loop;
@ -584,32 +688,27 @@ package body Ada.Tags is
-------------------
function Offset_To_Top
(This : System.Address) return System.Storage_Elements.Storage_Offset
(This : System.Address) return SSE.Storage_Offset
is
Curr_DT : constant Tag := To_Tag_Ptr (This).all;
Offset_To_Top : Storage_Offset_Ptr;
begin
Offset_To_Top := To_Storage_Offset_Ptr
(To_Address (Curr_DT) - K_Offset_To_Top);
Tag_Size : constant SSE.Storage_Count :=
SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
if Offset_To_Top.all = SSE.Storage_Offset'Last then
Offset_To_Top := To_Storage_Offset_Ptr (This + Tag_Size);
type Storage_Offset_Ptr is access SSE.Storage_Offset;
function To_Storage_Offset_Ptr is
new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
Curr_DT : Dispatch_Table_Ptr;
begin
Curr_DT := DT (To_Tag_Ptr (This).all);
if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then
return To_Storage_Offset_Ptr (This + Tag_Size).all;
else
return Curr_DT.Offset_To_Top;
end if;
return Offset_To_Top.all;
end Offset_To_Top;
---------
-- OSD --
---------
function OSD (T : Tag) return Object_Specific_Data_Ptr is
OSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - K_Typeinfo);
begin
return To_Object_Specific_Data_Ptr (OSD_Ptr.all);
end OSD;
-----------------
-- Parent_Size --
-----------------
@ -626,16 +725,28 @@ package body Ada.Tags is
-- 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
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
-- Pointer to the TSD
F : Acc_Size;
Parent_Tag : constant Tag := TSD.Tags_Table (Parent_Slot);
Parent_Predef_Prims_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (Parent_Tag)
- DT_Predef_Prims_Offset);
Parent_Predef_Prims : constant Predef_Prims_Table_Ptr :=
To_Predef_Prims_Table_Ptr
(Parent_Predef_Prims_Ptr.all);
-- The tag of the parent type through the dispatch table and its
-- Predef_Prims field.
F : constant Acc_Size :=
To_Acc_Size (Parent_Predef_Prims (Size_Slot));
-- Access to the _size primitive of the parent
begin
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
return SSE.Storage_Count (F.all (Obj));
@ -646,50 +757,29 @@ package body Ada.Tags is
----------------
function Parent_Tag (T : Tag) return Tag is
TSD_Ptr : Addr_Ptr;
TSD : Type_Specific_Data_Ptr;
begin
if T = No_Tag then
raise Tag_Error;
end if;
TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
-- The Parent_Tag of a root-level tagged type is defined to be No_Tag.
-- The first entry in the Ancestors_Tags array will be null for such
-- a type, but it's better to be explicit about returning No_Tag in
-- this case.
if TSD (T).Idepth = 0 then
if TSD.Idepth = 0 then
return No_Tag;
else
return TSD (T).Tags_Table (1);
return TSD.Tags_Table (1);
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 --
----------------------------
procedure Register_Interface_Tag
(T : Tag;
Interface_T : Tag;
Position : Positive)
is
New_T_TSD : Type_Specific_Data_Ptr;
Iface_Table : Interface_Data_Ptr;
begin
New_T_TSD := TSD (T);
Iface_Table := To_Interface_Data_Ptr (New_T_TSD.Ifaces_Table_Ptr);
Iface_Table.Ifaces_Table (Position).Iface_Tag := Interface_T;
end Register_Interface_Tag;
------------------
-- Register_Tag --
------------------
@ -712,86 +802,54 @@ package body Ada.Tags is
SSD (T).SSD_Table (Position).Index := Value;
end Set_Entry_Index;
-------------------------
-- Set_Interface_Table --
-------------------------
procedure Set_Interface_Table (T : Tag; Value : System.Address) is
begin
TSD (T).Ifaces_Table_Ptr := Value;
end Set_Interface_Table;
----------------------
-- Set_Offset_Index --
----------------------
procedure Set_Offset_Index
(T : Tag;
Position : Positive;
Value : Positive)
is
begin
OSD (T).OSD_Table (Position) := Value;
end Set_Offset_Index;
-----------------------
-- Set_Offset_To_Top --
-----------------------
procedure Set_Offset_To_Top
(This : System.Address;
Interface_T : Tag;
Is_Static : Boolean;
Offset_Value : System.Storage_Elements.Storage_Offset;
Offset_Func : System.Address)
(This : System.Address;
Interface_T : Tag;
Is_Static : Boolean;
Offset_Value : SSE.Storage_Offset;
Offset_Func : Offset_To_Top_Function_Ptr)
is
Prim_DT : Tag;
Sec_Base : System.Address;
Sec_DT : Tag;
Offset_To_Top : Storage_Offset_Ptr;
Iface_Table : Interface_Data_Ptr;
Obj_TSD : Type_Specific_Data_Ptr;
Prim_DT : Dispatch_Table_Ptr;
Sec_Base : System.Address;
Sec_DT : Dispatch_Table_Ptr;
Iface_Table : Interface_Data_Ptr;
begin
if System."=" (This, System.Null_Address) then
Offset_To_Top :=
To_Storage_Offset_Ptr (To_Address (Interface_T) - K_Offset_To_Top);
Offset_To_Top.all := Offset_Value;
return;
end if;
-- "This" points to the primary DT and we must save Offset_Value in the
-- Offset_To_Top field of the corresponding secondary dispatch table.
Prim_DT := To_Tag_Ptr (This).all;
-- Save the offset to top field in the secondary dispatch table.
-- Save the offset to top field in the secondary dispatch table
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);
Sec_DT := DT (To_Tag_Ptr (Sec_Base).all);
if Is_Static then
Offset_To_Top.all := Offset_Value;
Sec_DT.Offset_To_Top := Offset_Value;
else
Offset_To_Top.all := SSE.Storage_Offset'Last;
Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last;
end if;
end if;
-- Save Offset_Value in the table of interfaces of the primary DT. This
-- data will be used by the subprogram "Displace" to give support to
-- backward abstract interface type conversions.
-- "This" points to the primary DT and we must save Offset_Value in
-- the Offset_To_Top field of the corresponding secondary dispatch
-- table.
Obj_TSD := TSD (Prim_DT);
Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
Prim_DT := DT (To_Tag_Ptr (This).all);
Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
-- Save Offset_Value in the table of interfaces of the primary DT.
-- This data will be used by the subprogram "Displace" to give support
-- to backward abstract interface type conversions.
-- Register the offset in the table of interfaces
if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop
if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then
Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := Is_Static;
Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top :=
Is_Static;
if Is_Static then
Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value
@ -811,17 +869,6 @@ package body Ada.Tags is
raise Program_Error;
end Set_Offset_To_Top;
-------------
-- Set_OSD --
-------------
procedure Set_OSD (T : Tag; Value : System.Address) is
OSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - K_Typeinfo);
begin
OSD_Ptr.all := Value;
end Set_OSD;
----------------------
-- Set_Prim_Op_Kind --
----------------------
@ -835,70 +882,6 @@ package body Ada.Tags is
SSD (T).SSD_Table (Position).Kind := Value;
end Set_Prim_Op_Kind;
-------------------
-- Set_Signature --
-------------------
procedure Set_Signature (T : Tag; Value : Signature_Kind) is
Signature : constant System.Address := To_Address (T) - K_Signature;
Sig_Ptr : constant Signature_Values_Ptr :=
To_Signature_Values_Ptr (Signature);
begin
Sig_Ptr.all (1) := Valid_Signature;
Sig_Ptr.all (2) := Value;
end Set_Signature;
-------------
-- Set_SSD --
-------------
procedure Set_SSD (T : Tag; Value : System.Address) is
begin
TSD (T).SSD_Ptr := Value;
end Set_SSD;
---------------------
-- Set_Tagged_Kind --
---------------------
procedure Set_Tagged_Kind (T : Tag; Value : Tagged_Kind) is
Tagged_Kind_Ptr : constant System.Address :=
To_Address (T) - K_Tagged_Kind;
begin
To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all := Value;
end Set_Tagged_Kind;
---------
-- SSD --
---------
function SSD (T : Tag) return Select_Specific_Data_Ptr is
begin
return To_Select_Specific_Data_Ptr (TSD (T).SSD_Ptr);
end SSD;
------------------
-- Typeinfo_Ptr --
------------------
function Typeinfo_Ptr (T : Tag) return System.Address is
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - K_Typeinfo);
begin
return TSD_Ptr.all;
end Typeinfo_Ptr;
---------
-- TSD --
---------
function TSD (T : Tag) return Type_Specific_Data_Ptr is
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - K_Typeinfo);
begin
return To_Type_Specific_Data_Ptr (TSD_Ptr.all);
end TSD;
------------------------
-- Wide_Expanded_Name --
------------------------

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

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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 --
@ -37,7 +37,7 @@
with System;
with System.Storage_Elements;
with Unchecked_Conversion;
with Ada.Unchecked_Conversion;
package Ada.Tags is
pragma Preelaborate_05;
@ -83,18 +83,16 @@ package Ada.Tags is
private
-- Structure of the GNAT Primary Dispatch Table
-- +--------------------+
-- | table of |
-- :predefined primitive:
-- | ops pointers |
-- +--------------------+
-- | Signature |
-- +--------------------+
-- | Tagged_Kind |
-- +--------------------+
-- | Offset_To_Top |
-- +--------------------+
-- |Typeinfo_Ptr/TSD_Ptr---> Type Specific Data
-- +--------------------+ Predef Prims
-- | Predef_Prims -----------------------------> +------------+
-- +--------------------+ | table of |
-- | Offset_To_Top | | predefined |
-- +--------------------+ | primitives |
-- |Typeinfo_Ptr/TSD_Ptr---> Type Specific Data +------------+
-- Tag ---> +--------------------+ +-------------------+
-- | table of | | inheritance depth |
-- : primitive ops : +-------------------+
@ -110,16 +108,14 @@ private
-- +-------------------+
-- | rec ctrler offset |
-- +-------------------+
-- | num prim ops |
-- +-------------------+
-- | Ifaces_Table_Ptr --> Interface Data
-- | Ifaces_Table ---> Interface Data
-- +-------------------+ +------------+
-- Select Specific Data <---- SSD_Ptr | | table |
-- +------------------+ +-------------------+ : of :
-- |table of primitive| | table of | | interfaces |
-- : operation : : ancestor : +------------+
-- | kinds | | tags |
-- +------------------+ +-------------------+
-- Select Specific Data <---- SSD | | Nb_Ifaces |
-- +------------------+ +-------------------+ +------------+
-- |table of primitive| | table of | | table |
-- : operation : : ancestor : : of :
-- | kinds | | tags | | interfaces |
-- +------------------+ +-------------------+ +------------+
-- |table of |
-- : entry :
-- | indices |
@ -148,163 +144,45 @@ private
-- +---------------+
-- The runtime information kept for each tagged type is separated into two
-- objects: the Dispatch Table and the Type Specific Data record. These
-- two objects are allocated statically using the constants:
-- objects: the Dispatch Table and the Type Specific Data record.
-- DT Size = DT_Prologue_Size + Nb_Prim * DT_Entry_Size
-- where Nb_prim is the number of primitive operations of the given
-- type and Idepth its inheritance depth.
type Address_Array is array (Natural range <>) of System.Address;
pragma Suppress (Index_Check, On => Address_Array);
-- The reason we suppress index checks is that in the dispatch table,
-- the component of this type is declared with a dummy size of 1, the
-- actual size depending on the number of primitive operations.
type Dispatch_Table is record
-- According to the C++ ABI the components Offset_To_Top and
-- Typeinfo_Ptr are stored just "before" the dispatch table (that is,
-- the Prims_Ptr table), and they are referenced with negative offsets
-- referring to the base of the dispatch table. The _Tag (or the
-- VTable_Ptr in C++ terminology) must point to the base of the virtual
-- table, just after these components, to point to the Prims_Ptr table.
-- For this purpose the expander generates a Prims_Ptr table that has
-- enough space for these additional components, and generates code that
-- displaces the _Tag to point after these components.
-- Signature : Signature_Kind;
-- Tagged_Kind : Tagged_Kind;
-- Offset_To_Top : Natural;
-- Typeinfo_Ptr : System.Address;
Prims_Ptr : Address_Array (1 .. 1);
-- The size of the Prims_Ptr array actually depends on the tagged type
-- to which it applies. For each tagged type, the expander computes the
-- actual array size, allocates the Dispatch_Table record accordingly,
-- and generates code that displaces the base of the record after the
-- Typeinfo_Ptr component. For this reason the first two components have
-- been commented in the previous declaration. The access to these
-- components is done by means of local functions.
--
-- To avoid the use of discriminants to define the actual size of the
-- dispatch table, we used to declare the tag as a pointer to a record
-- that contains an arbitrary array of addresses, using Positive as its
-- index. This ensures that there are never range checks when accessing
-- the dispatch table, but it prevents GDB from displaying tagged types
-- properly. A better approach is to declare this record type as holding
-- small number of addresses, and to explicitly suppress checks on it.
--
-- Note that in both cases, this type is never allocated, and serves
-- only to declare the corresponding access type.
end record;
package SSE renames System.Storage_Elements;
subtype Cstring is String (Positive);
type Cstring_Ptr is access all Cstring;
pragma No_Strict_Aliasing (Cstring_Ptr);
-- We suppress index checks because the declared size in the record below
-- is a dummy size of one (see below).
type Tag_Table is array (Natural range <>) of Tag;
pragma Suppress_Initialization (Tag_Table);
pragma Suppress (Index_Check, On => Tag_Table);
package SSE renames System.Storage_Elements;
-- Type specific data types
type Type_Specific_Data (Idepth : Natural) is record
-- Inheritance Depth Level: Used to implement the membership test
-- associated with single inheritance of tagged types in constant-time.
-- It also indicates the size of the Tags_Table component.
Access_Level : Natural;
-- Accessibility level required to give support to Ada 2005 nested type
-- extensions. This feature allows safe nested type extensions by
-- shifting the accessibility checks to certain operations, rather than
-- being enforced at the type declaration. In particular, by performing
-- run-time accessibility checks on class-wide allocators, class-wide
-- function return, and class-wide stream I/O, the danger of objects
-- outliving their type declaration can be eliminated (Ada 2005: AI-344)
Expanded_Name : Cstring_Ptr;
External_Tag : Cstring_Ptr;
HT_Link : Tag;
-- Components used to support to the Ada.Tags subprograms in RM 3.9.
-- Note: Expanded_Name is referenced by GDB ???
Remotely_Callable : Boolean;
-- Used to check ARM E.4 (18)
RC_Offset : SSE.Storage_Offset;
-- Controller Offset: Used to give support to tagged controlled objects
-- (see Get_Deep_Controller at s-finimp)
Ifaces_Table_Ptr : System.Address;
-- Pointer to the table of interface tags. It is used to implement the
-- membership test associated with interfaces and also for backward
-- abstract interface type conversions (Ada 2005:AI-251)
SSD_Ptr : System.Address;
-- Pointer to a table of records used in dispatching selects. This
-- field has a meaningful value for all tagged types that implement
-- a limited, protected, synchronized or task interfaces and have
-- non-predefined primitive operations.
Tags_Table : Tag_Table (0 .. Idepth);
-- Table of ancestor tags. Its size actually depends on the inheritance
-- depth level of the tagged type.
end record;
-- Declarations for the table of interfaces
type Offset_To_Top_Function_Ptr is
access function (This : System.Address) return SSE.Storage_Offset;
-- Type definition used to call the function that is generated by the
-- expander in case of tagged types with discriminants that have secondary
-- dispatch tables. This function provides the Offset_To_Top value in this
-- specific case.
type Interface_Data_Element is record
Iface_Tag : Tag;
Static_Offset_To_Top : Boolean;
Offset_To_Top_Value : System.Storage_Elements.Storage_Offset;
Offset_To_Top_Func : System.Address;
Offset_To_Top_Value : SSE.Storage_Offset;
Offset_To_Top_Func : Offset_To_Top_Function_Ptr;
end record;
-- If some ancestor of the tagged type has discriminants the field
-- Static_Offset_To_Top is False and the field Offset_To_Top_Func
-- is used to store the address of the function generated by the
-- is used to store the access to the function generated by the
-- expander which provides this value; otherwise Static_Offset_To_Top
-- is True and such value is stored in the Offset_To_Top_Value field.
type Interfaces_Array is
array (Natural range <>) of Interface_Data_Element;
type Interfaces_Array is array (Natural range <>) of Interface_Data_Element;
type Interface_Data (Nb_Ifaces : Positive) is record
Ifaces_Table : Interfaces_Array (1 .. Nb_Ifaces);
end record;
-- Declaration of tag types
type Tag is access all Dispatch_Table;
type Tag_Ptr is access Tag;
type Interface_Tag is access all Dispatch_Table;
type Type_Specific_Data_Ptr is access all Type_Specific_Data;
No_Tag : constant Tag := null;
type Interface_Data_Ptr is access all Interface_Data;
-- Table of abstract interfaces used to give support to backward interface
-- conversions and also to IW_Membership.
type Object_Specific_Data (Nb_Prim : Positive);
type Object_Specific_Data_Ptr is access all Object_Specific_Data;
-- Information associated with the secondary dispatch table of tagged-type
-- objects implementing abstract interfaces.
type Select_Specific_Data (Nb_Prim : Positive);
type Select_Specific_Data_Ptr is access all Select_Specific_Data;
-- A table used to store the primitive operation kind and entry index of
-- primitive subprograms of a type that implements a limited interface.
-- The Select Specific Data table resides in the Type Specific Data of a
-- type. This construct is used in the handling of dispatching triggers
-- in select statements.
-- Primitive operation kinds. These values differentiate the kinds of
-- callable entities stored in the dispatch table. Certain kinds may
-- not be used, but are added for completeness.
@ -319,6 +197,90 @@ private
POK_Task_Function,
POK_Task_Procedure);
-- Select specific data types
type Select_Specific_Data_Element is record
Index : Positive;
Kind : Prim_Op_Kind;
end record;
type Select_Specific_Data_Array is
array (Positive range <>) of Select_Specific_Data_Element;
type Select_Specific_Data (Nb_Prim : Positive) is record
SSD_Table : Select_Specific_Data_Array (1 .. Nb_Prim);
-- NOTE: Nb_Prim is the number of non-predefined primitive operations
end record;
type Select_Specific_Data_Ptr is access all Select_Specific_Data;
-- A table used to store the primitive operation kind and entry index of
-- primitive subprograms of a type that implements a limited interface.
-- The Select Specific Data table resides in the Type Specific Data of a
-- type. This construct is used in the handling of dispatching triggers
-- in select statements.
type Tag_Table is array (Natural range <>) of Tag;
type Type_Specific_Data (Idepth : Natural) is record
-- The discriminant Idepth is the Inheritance Depth Level: Used to
-- implement the membership test associated with single inheritance of
-- tagged types in constant-time. It also indicates the size of the
-- Tags_Table component.
Access_Level : Natural;
-- Accessibility level required to give support to Ada 2005 nested type
-- extensions. This feature allows safe nested type extensions by
-- shifting the accessibility checks to certain operations, rather than
-- being enforced at the type declaration. In particular, by performing
-- run-time accessibility checks on class-wide allocators, class-wide
-- function return, and class-wide stream I/O, the danger of objects
-- outliving their type declaration can be eliminated (Ada 2005: AI-344)
Expanded_Name : Cstring_Ptr;
External_Tag : Cstring_Ptr;
HT_Link : Tag;
-- Components used to support to the Ada.Tags subprograms in RM 3.9
-- Note: Expanded_Name is referenced by GDB to determine the actual name
-- of the tagged type. Its requirements are: 1) it must have this exact
-- name, and 2) its contents must point to a C-style Nul terminated
-- string containing its expanded name. GDB has no requirement on a
-- given position inside the record.
Transportable : Boolean;
-- Used to check RM E.4(18), set for types that satisfy the requirements
-- for being used in remote calls as actuals for classwide formals or as
-- return values for classwide functions.
RC_Offset : SSE.Storage_Offset;
-- Controller Offset: Used to give support to tagged controlled objects
-- (see Get_Deep_Controller at s-finimp)
Interfaces_Table : Interface_Data_Ptr;
-- Pointer to the table of interface tags. It is used to implement the
-- membership test associated with interfaces and also for backward
-- abstract interface type conversions (Ada 2005:AI-251)
SSD : Select_Specific_Data_Ptr;
-- Pointer to a table of records used in dispatching selects. This
-- field has a meaningful value for all tagged types that implement
-- a limited, protected, synchronized or task interfaces and have
-- non-predefined primitive operations.
Tags_Table : Tag_Table (0 .. Idepth);
-- Table of ancestor tags. Its size actually depends on the inheritance
-- depth level of the tagged type.
end record;
type Type_Specific_Data_Ptr is access all Type_Specific_Data;
-- Declarations for the dispatch table record
type Signature_Kind is
(Unknown,
Primary_DT,
Secondary_DT);
-- Tagged type kinds with respect to concurrency and limitedness
type Tagged_Kind is
@ -329,53 +291,66 @@ private
TK_Tagged,
TK_Task);
type Tagged_Kind_Ptr is access all Tagged_Kind;
type Address_Array is array (Positive range <>) of System.Address;
type Dispatch_Table_Wrapper (Num_Prims : Natural) is record
Signature : Signature_Kind;
Tag_Kind : Tagged_Kind;
Predef_Prims : System.Address;
-- Pointer to the dispatch table of predefined Ada primitives
-- According to the C++ ABI the components Offset_To_Top and TSD are
-- stored just "before" the dispatch table, and they are referenced with
-- negative offsets referring to the base of the dispatch table. The
-- _Tag (or the VTable_Ptr in C++ terminology) must point to the base
-- of the virtual table, just after these components, to point to the
-- Prims_Ptr table.
Offset_To_Top : SSE.Storage_Offset;
TSD : System.Address;
Prims_Ptr : aliased Address_Array (1 .. Num_Prims);
-- The size of the Prims_Ptr array actually depends on the tagged type
-- to which it applies. For each tagged type, the expander computes the
-- actual array size, allocates the Dispatch_Table record accordingly.
end record;
subtype Dispatch_Table is Address_Array (1 .. 1);
-- Used by GDB to identify the _tags and traverse the run-time structure
-- associated with tagged types. For compatibility with older versions of
-- gdb, its name must not be changed.
type Tag is access all Dispatch_Table;
type Interface_Tag is access all Dispatch_Table;
No_Tag : constant Tag := null;
-- The expander ensures that Tag objects reference the Prims_Ptr component
-- of the wrapper.
type Tag_Ptr is access all Tag;
type Dispatch_Table_Ptr is access all Dispatch_Table_Wrapper;
-- The following type declaration is used by the compiler when the program
-- is compiled with restriction No_Dispatching_Calls. It is also used with
-- interface types to generate the tag and run-time information associated
-- with them.
type No_Dispatch_Table_Wrapper is record
NDT_TSD : System.Address;
NDT_Prims_Ptr : Natural;
end record;
Default_Prim_Op_Count : constant Positive := 15;
-- Maximum number of predefined primitive operations of a tagged type.
-- Number of predefined ada primitives: Size, Alignment, Read, Write,
-- Input, Output, "=", assignment, deep adjust, deep finalize, async
-- select, conditional select, prim_op kind, task_id, and timed select.
type Signature_Kind is
(Unknown,
Valid_Signature,
Primary_DT,
Secondary_DT,
Abstract_Interface);
for Signature_Kind'Size use 8;
-- Kind of signature found in the header of the dispatch table. These
-- signatures are generated by the frontend and are used by the Check_XXX
-- routines to ensure that the kind of dispatch table managed by each of
-- the routines in this package is correct. This additional check is only
-- performed with this run-time package is compiled with assertions enabled
-- The signature is a sequence of two bytes. The first byte must have the
-- value Valid_Signature, and the second byte must have a value in the
-- range Primary_DT .. Abstract_Interface. The Unknown value is used by
-- the Check_XXX routines to indicate that the signature is wrong.
DT_Min_Prologue_Size : constant SSE.Storage_Count :=
DT_Predef_Prims_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(2 * (Standard'Address_Size /
(1 * (Standard'Address_Size /
System.Storage_Unit));
-- Size of the hidden part of the dispatch table used when the program
-- is compiled under restriction No_Dispatching_Calls. It contains the
-- pointer to the TSD record plus a dummy entry whose address is used
-- at run-time as the Tag.
DT_Prologue_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
((Default_Prim_Op_Count + 4) *
(Standard'Address_Size / System.Storage_Unit));
-- Size of the hidden part of the dispatch table. It contains the table of
-- predefined primitive operations plus the C++ ABI header.
DT_Signature_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(1 * (Standard'Address_Size / System.Storage_Unit));
-- Size of the Signature field of the dispatch table
DT_Tagged_Kind_Size : constant SSE.Storage_Count :=
SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
-- Size of the Tagged_Type_Kind field of the dispatch table
-- Size of the Predef_Prims field of the Dispatch_Table
DT_Offset_To_Top_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
@ -389,28 +364,27 @@ private
System.Storage_Unit));
-- Size of the Typeinfo_Ptr field of the Dispatch Table
DT_Entry_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(1 * (Standard'Address_Size / System.Storage_Unit));
-- Size of each primitive operation entry in the Dispatch Table
use type System.Storage_Elements.Storage_Offset;
Tag_Size : constant SSE.Storage_Count :=
SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
-- Size of each tag
DT_Predef_Prims_Offset : constant SSE.Storage_Count :=
DT_Typeinfo_Ptr_Size
+ DT_Offset_To_Top_Size
+ DT_Predef_Prims_Size;
-- Offset from Prims_Ptr to Predef_Prims component
-- Constants used by the code generated by the frontend to get access
-- to the header of the dispatch table.
-- Object Specific Data record of secondary dispatch tables
K_Typeinfo : constant SSE.Storage_Count := DT_Typeinfo_Ptr_Size;
K_Offset_To_Top : constant SSE.Storage_Count :=
System.Storage_Elements."+"
(K_Typeinfo, DT_Offset_To_Top_Size);
K_Tagged_Kind : constant SSE.Storage_Count :=
System.Storage_Elements."+"
(K_Offset_To_Top, DT_Tagged_Kind_Size);
K_Signature : constant SSE.Storage_Count :=
System.Storage_Elements."+"
(K_Tagged_Kind, DT_Signature_Size);
type Object_Specific_Data_Array is array (Positive range <>) of Positive;
type Object_Specific_Data (OSD_Num_Prims : Positive) is record
OSD_Table : Object_Specific_Data_Array (1 .. OSD_Num_Prims);
-- Table used in secondary DT to reference their counterpart in the
-- select specific data (in the TSD of the primary DT). This construct
-- is used in the handling of dispatching triggers in select statements.
-- Nb_Prim is the number of non-predefined primitive operations.
end record;
type Object_Specific_Data_Ptr is access all Object_Specific_Data;
-- The following subprogram specifications are placed here instead of
-- the package body to see them from the frontend through rtsfind.
@ -419,21 +393,17 @@ private
-- Ada 2005 (AI-251): Displace "This" to point to the base address of
-- the object (that is, the address of the primary tag of the object).
function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
-- Given the tag of an object and the tag associated to a type, return
-- true if Obj is in Typ'Class.
function Displace (This : System.Address; T : Tag) return System.Address;
-- Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch
-- table of T.
function DT (T : Tag) return Dispatch_Table_Ptr;
-- Return the pointer to the TSD record associated with T
function Get_Entry_Index (T : Tag; Position : Positive) return Positive;
-- Ada 2005 (AI-251): Return a primitive operation's entry index (if entry)
-- given a dispatch table T and a position of a primitive operation in T.
function Get_External_Tag (T : Tag) return System.Address;
-- Returns address of a null terminated string containing the external name
function Get_Offset_Index
(T : Tag;
Position : Positive) return Positive;
@ -450,7 +420,7 @@ private
function Get_RC_Offset (T : Tag) return SSE.Storage_Offset;
-- Return the Offset of the implicit record controller when the object
-- has controlled components. O otherwise.
-- has controlled components, returns zero if no controlled components.
pragma Export (Ada, Get_RC_Offset, "ada__tags__get_rc_offset");
-- This procedure is used in s-finimp to compute the deep routines
@ -477,17 +447,12 @@ private
-- end Test;
function Offset_To_Top
(This : System.Address) return System.Storage_Elements.Storage_Offset;
(This : System.Address) return SSE.Storage_Offset;
-- Ada 2005 (AI-251): Returns the current value of the offset_to_top
-- component available in the prologue of the dispatch table. If the parent
-- of the tagged type has discriminants this value is stored in a record
-- component just immediately after the tag component.
function OSD (T : Tag) return Object_Specific_Data_Ptr;
-- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table,
-- retrieve the address of the record containing the Object Specific
-- Data table.
function Parent_Size
(Obj : System.Address;
T : Tag) return SSE.Storage_Count;
@ -499,14 +464,6 @@ private
pragma Export (Ada, Parent_Size, "ada__tags__parent_size");
-- This procedure is used in s-finimp and is thus exported manually
procedure Register_Interface_Tag
(T : Tag;
Interface_T : Tag;
Position : Positive);
-- Ada 2005 (AI-251): Used to initialize the table of interfaces
-- implemented by a type. Required to give support to backward interface
-- conversions and also to IW_Membership.
procedure Register_Tag (T : Tag);
-- Insert the Tag and its associated external_tag in a table for the
-- sake of Internal_Tag
@ -515,23 +472,12 @@ private
-- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's
-- TSD table indexed by Position.
procedure Set_Interface_Table (T : Tag; Value : System.Address);
-- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, stores the
-- pointer to the table of interfaces.
procedure Set_Offset_Index
(T : Tag;
Position : Positive;
Value : Positive);
-- Ada 2005 (AI-345): Set the offset value of a primitive operation in a
-- secondary dispatch table denoted by T, indexed by Position.
procedure Set_Offset_To_Top
(This : System.Address;
Interface_T : Tag;
Is_Static : Boolean;
Offset_Value : System.Storage_Elements.Storage_Offset;
Offset_Func : System.Address);
Offset_Value : SSE.Storage_Offset;
Offset_Func : Offset_To_Top_Function_Ptr);
-- Ada 2005 (AI-251): Initialize the Offset_To_Top field in the prologue of
-- the dispatch table. In primary dispatch tables the value of "This" is
-- not required (and the compiler passes always the Null_Address value) and
@ -541,11 +487,6 @@ private
-- distance from "This" to the object component containing the tag of the
-- secondary dispatch table.
procedure Set_OSD (T : Tag; Value : System.Address);
-- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table,
-- store the pointer to the record containing the Object Specific Data
-- generated by GNAT.
procedure Set_Prim_Op_Kind
(T : Tag;
Position : Positive;
@ -553,94 +494,52 @@ private
-- Ada 2005 (AI-251): Set the kind of a primitive operation in T's TSD
-- table indexed by Position.
procedure Set_Signature (T : Tag; Value : Signature_Kind);
-- Given a pointer T to a dispatch table, store the signature id
procedure Set_SSD (T : Tag; Value : System.Address);
-- Ada 2005 (AI-345): Given a pointer T to a dispatch Table, stores the
-- pointer to the record containing the Select Specific Data generated by
-- GNAT.
procedure Set_Tagged_Kind (T : Tag; Value : Tagged_Kind);
-- Ada 2005 (AI-345): Set the tagged kind of a type in either a primary or
-- a secondary dispatch table denoted by T.
function SSD (T : Tag) return Select_Specific_Data_Ptr;
-- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, retrieves the
-- address of the record containing the Select Specific Data in T's TSD.
function TSD (T : Tag) return Type_Specific_Data_Ptr;
-- Given a pointer T to a dispatch Table, retrieves the address of the
-- record containing the Type Specific Data generated by GNAT.
-- Unchecked Conversions
Max_Predef_Prims : constant Natural := 16;
-- Compiler should check this constant is OK ???
subtype Predef_Prims_Table is Address_Array (1 .. Max_Predef_Prims);
type Predef_Prims_Table_Ptr is access Predef_Prims_Table;
type Addr_Ptr is access System.Address;
type Signature_Values is
array (1 .. DT_Signature_Size) of Signature_Kind;
-- Type used to see the signature as a sequence of Signature_Kind values
type Signature_Values_Ptr is access all Signature_Values;
function To_Addr_Ptr is
new Unchecked_Conversion (System.Address, Addr_Ptr);
function To_Type_Specific_Data_Ptr is
new Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
new Ada.Unchecked_Conversion (System.Address, Addr_Ptr);
function To_Address is
new Unchecked_Conversion (Tag, System.Address);
new Ada.Unchecked_Conversion (Tag, System.Address);
function To_Interface_Data_Ptr is
new Unchecked_Conversion (System.Address, Interface_Data_Ptr);
function To_Dispatch_Table_Ptr is
new Ada.Unchecked_Conversion (Tag, Dispatch_Table_Ptr);
function To_Dispatch_Table_Ptr is
new Ada.Unchecked_Conversion (System.Address, Dispatch_Table_Ptr);
function To_Object_Specific_Data_Ptr is
new Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr);
new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr);
function To_Select_Specific_Data_Ptr is
new Unchecked_Conversion (System.Address, Select_Specific_Data_Ptr);
function To_Signature_Values is
new Unchecked_Conversion (System.Storage_Elements.Storage_Offset,
Signature_Values);
function To_Signature_Values_Ptr is
new Unchecked_Conversion (System.Address,
Signature_Values_Ptr);
function To_Tag is
new Unchecked_Conversion (System.Address, Tag);
function To_Predef_Prims_Table_Ptr is
new Ada.Unchecked_Conversion (System.Address, Predef_Prims_Table_Ptr);
function To_Tag_Ptr is
new Unchecked_Conversion (System.Address, Tag_Ptr);
new Ada.Unchecked_Conversion (System.Address, Tag_Ptr);
function To_Tagged_Kind_Ptr is
new Unchecked_Conversion (System.Address, Tagged_Kind_Ptr);
function To_Type_Specific_Data_Ptr is
new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
-- Primitive dispatching operations are always inlined, to facilitate
-- use in a minimal/no run-time environment for high integrity use.
-- Primitive dispatching operations are always inlined, to facilitate use
-- in a minimal/no run-time environment for high integrity use.
pragma Inline_Always (CW_Membership);
pragma Inline_Always (Displace);
pragma Inline_Always (IW_Membership);
pragma Inline_Always (Get_Entry_Index);
pragma Inline_Always (Get_Offset_Index);
pragma Inline_Always (Get_Prim_Op_Kind);
pragma Inline_Always (Get_Tagged_Kind);
pragma Inline_Always (OSD);
pragma Inline_Always (Register_Interface_Tag);
pragma Inline_Always (Register_Tag);
pragma Inline_Always (Set_Entry_Index);
pragma Inline_Always (Set_Interface_Table);
pragma Inline_Always (Set_Offset_Index);
pragma Inline_Always (Set_Offset_To_Top);
pragma Inline_Always (Set_Prim_Op_Kind);
pragma Inline_Always (Set_Signature);
pragma Inline_Always (Set_OSD);
pragma Inline_Always (Set_SSD);
pragma Inline_Always (Set_Tagged_Kind);
pragma Inline_Always (SSD);
pragma Inline_Always (TSD);
end Ada.Tags;

738
gcc/ada/exp_atag.adb
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2006, Free Software Foundation, Inc. --
-- Copyright (C) 2006-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -24,16 +24,15 @@
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Util; use Exp_Util;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Stand; use Stand;
with Snames; use Snames;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
package body Exp_Atag is
@ -41,33 +40,107 @@ package body Exp_Atag is
-- Local Subprograms --
-----------------------
function Build_Predefined_DT
function Build_DT
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id;
-- Build code that displaces the Tag to reference the dispatch table
-- containing the predefined primitives.
-- Build code that displaces the Tag to reference the base of the wrapper
-- record
--
-- Generates: To_Tag (To_Address (Tag_Node) - DT_Prologue_Size);
pragma Inline (Build_Predefined_DT);
function Build_Typeinfo_Offset (Loc : Source_Ptr) return Node_Id;
-- Build code that gives access to the distance from the tag to the
-- Typeinfo component of the dispatch table.
--
-- Generates: DT_Typeinfo_Ptr_Size
pragma Inline (Build_Typeinfo_Offset);
-- Generates:
-- To_Dispatch_Table_Ptr
-- (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position);
function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id;
-- Build code that retrieves the address of the record containing the Type
-- Specific Data generated by GNAT.
--
-- Generate: To_Type_Specific_Data_Ptr
-- (To_Address_Ptr (To_Address (Tag) - Typeinfo_Offset).all);
pragma Inline (Build_TSD);
-- (To_Addr_Ptr (To_Address (Tag) - Typeinfo_Offset).all);
function RTE_Tag_Node return Entity_Id;
-- Returns the entity associated with Ada.Tags.Tag
pragma Inline (RTE_Tag_Node);
function Build_Predef_Prims
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id;
-- Build code that retrieves the address of the dispatch table containing
-- the predefined Ada primitives:
--
-- Generate: To_Predef_Prims_Table_Ptr
-- (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all);
------------------------------------------------
-- Build_Common_Dispatching_Select_Statements --
------------------------------------------------
procedure Build_Common_Dispatching_Select_Statements
(Loc : Source_Ptr;
DT_Ptr : Entity_Id;
Stmts : List_Id)
is
begin
-- Generate:
-- C := get_prim_op_kind (tag! (<type>VP), S);
-- where C is the out parameter capturing the call kind and S is the
-- dispatch table slot number.
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name =>
Make_Identifier (Loc, Name_uC),
Expression =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (DT_Ptr, Loc)),
Make_Identifier (Loc, Name_uS)))));
-- Generate:
-- if C = POK_Procedure
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure;
-- then
-- F := True;
-- return;
-- where F is the out parameter capturing the status of a potential
-- entry call.
Append_To (Stmts,
Make_If_Statement (Loc,
Condition =>
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Identifier (Loc, Name_uC),
Right_Opnd =>
New_Reference_To (RTE (RE_POK_Procedure), Loc)),
Right_Opnd =>
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Identifier (Loc, Name_uC),
Right_Opnd =>
New_Reference_To (RTE (
RE_POK_Protected_Procedure), Loc)),
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Identifier (Loc, Name_uC),
Right_Opnd =>
New_Reference_To (RTE (
RE_POK_Task_Procedure), Loc)))),
Then_Statements =>
New_List (
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uF),
Expression => New_Reference_To (Standard_True, Loc)),
Make_Return_Statement (Loc))));
end Build_Common_Dispatching_Select_Statements;
-------------------------
-- Build_CW_Membership --
@ -103,27 +176,42 @@ package body Exp_Atag is
begin
return
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Ge (Loc,
Left_Opnd => Build_Pos,
Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
Left_Opnd =>
Make_Op_Ge (Loc,
Left_Opnd => Build_Pos,
Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Indexed_Component (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Obj_Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Tags_Table), Loc)),
Expressions =>
New_List (Build_Pos)),
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Indexed_Component (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Obj_Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Tags_Table), Loc)),
Expressions =>
New_List (Build_Pos)),
Right_Opnd => Typ_Tag_Node));
Right_Opnd => Typ_Tag_Node));
end Build_CW_Membership;
--------------
-- Build_DT --
--------------
function Build_DT
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id is
begin
return
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_DT), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Tag), Tag_Node)));
end Build_DT;
----------------------------
-- Build_Get_Access_Level --
----------------------------
@ -146,125 +234,18 @@ package body Exp_Atag is
------------------------------------------
function Build_Get_Predefined_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id) return Node_Id
is
begin
return
Make_Indexed_Component (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Build_Predefined_DT (Loc, Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Expressions =>
New_List (Position_Node));
end Build_Get_Predefined_Prim_Op_Address;
-------------------------------
-- Build_Get_Prim_Op_Address --
-------------------------------
function Build_Get_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id) return Node_Id
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position : Uint) return Node_Id
is
begin
return
Make_Indexed_Component (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To
(RTE_Tag_Node, Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Expressions => New_List (Position_Node));
end Build_Get_Prim_Op_Address;
-------------------------
-- Build_Get_RC_Offset --
-------------------------
function Build_Get_RC_Offset
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id
is
begin
return
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_RC_Offset), Loc));
end Build_Get_RC_Offset;
---------------------------------
-- Build_Get_Remotely_Callable --
---------------------------------
function Build_Get_Remotely_Callable
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id
is
begin
return
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Remotely_Callable), Loc));
end Build_Get_Remotely_Callable;
------------------------------------
-- Build_Inherit_Predefined_Prims --
------------------------------------
function Build_Inherit_Predefined_Prims
(Loc : Source_Ptr;
Old_Tag_Node : Node_Id;
New_Tag_Node : Node_Id) return Node_Id
is
begin
return
Make_Assignment_Statement (Loc,
Name =>
Make_Slice (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Build_Predefined_DT (Loc, New_Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Discrete_Range => Make_Range (Loc,
Make_Integer_Literal (Loc, Uint_1),
New_Reference_To (RTE (RE_Default_Prim_Op_Count), Loc))),
Expression =>
Make_Slice (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Build_Predefined_DT (Loc, Old_Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Discrete_Range =>
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 1),
High_Bound =>
New_Reference_To (RTE (RE_Default_Prim_Op_Count), Loc))));
end Build_Inherit_Predefined_Prims;
Build_Predef_Prims (Loc, Tag_Node),
Expressions =>
New_List (Make_Integer_Literal (Loc, Position)));
end Build_Get_Predefined_Prim_Op_Address;
-------------------------
-- Build_Inherit_Prims --
@ -284,7 +265,7 @@ package body Exp_Atag is
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (RTE_Tag_Node, New_Tag_Node),
Build_DT (Loc, New_Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
@ -298,7 +279,7 @@ package body Exp_Atag is
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (RTE_Tag_Node, Old_Tag_Node),
Build_DT (Loc, Old_Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
@ -308,281 +289,139 @@ package body Exp_Atag is
High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
end Build_Inherit_Prims;
-------------------
-- Build_New_TSD --
-------------------
-------------------------------
-- Build_Get_Prim_Op_Address --
-------------------------------
function Build_New_TSD
(Loc : Source_Ptr;
New_Tag_Node : Node_Id) return List_Id
function Build_Get_Prim_Op_Address
(Loc : Source_Ptr;
Typ : Entity_Id;
Tag_Node : Node_Id;
Position : Uint) return Node_Id
is
begin
return New_List (
Make_Assignment_Statement (Loc,
Name =>
Make_Indexed_Component (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Duplicate_Subexpr (New_Tag_Node)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Tags_Table), Loc)),
Expressions => New_List (Make_Integer_Literal (Loc, Uint_0))),
pragma Assert
(Position <= DT_Entry_Count (First_Tag_Component (Typ)));
Expression => New_Tag_Node));
end Build_New_TSD;
-----------------------
-- Build_Inherit_TSD --
-----------------------
function Build_Inherit_TSD
(Loc : Source_Ptr;
Old_Tag_Node : Node_Id;
New_Tag_Node : Node_Id;
I_Depth : Nat;
Parent_Num_Ifaces : Nat) return Node_Id
is
function Build_Iface_Table_Ptr (Tag_Node : Node_Id) return Node_Id;
-- Generates: Interface_Data_Ptr! (TSD (Tag).Ifaces_Table_Ptr).all
----------------------------
-- Build_Iface_Table_Ptr --
----------------------------
function Build_Iface_Table_Ptr (Tag_Node : Node_Id) return Node_Id is
begin
return
Unchecked_Convert_To (RTE (RE_Interface_Data_Ptr),
Make_Selected_Component (Loc,
Prefix => Tag_Node,
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Ifaces_Table_Ptr), Loc)));
end Build_Iface_Table_Ptr;
-- Local variables
L : constant List_Id := New_List;
Old_TSD : Node_Id;
New_TSD : Node_Id;
-- Start of processing for Build_Inherit_TSD
begin
Old_TSD :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, New_Internal_Name ('T')),
Object_Definition =>
New_Reference_To (RTE (RE_Type_Specific_Data_Ptr), Loc),
Expression =>
Build_TSD (Loc, Duplicate_Subexpr (Old_Tag_Node)));
New_TSD :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, New_Internal_Name ('T')),
Object_Definition =>
New_Reference_To (RTE (RE_Type_Specific_Data_Ptr), Loc),
Expression =>
Build_TSD (Loc, Duplicate_Subexpr (New_Tag_Node)));
Append_List_To (L, New_List (
-- Copy the table of ancestors of the parent
-- TSD (New_Tag).Tags_Table (1 .. I_Depth) :=
-- TSD (Old_Tag).Tags_Table (0 .. I_Depth - 1);
Make_Assignment_Statement (Loc,
Name =>
Make_Slice (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Explicit_Dereference (Loc,
New_Reference_To (Defining_Identifier (New_TSD), Loc)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Tags_Table), Loc)),
Discrete_Range => Make_Range (Loc,
Make_Integer_Literal (Loc, Uint_1),
Make_Integer_Literal (Loc, I_Depth))),
Expression =>
Make_Slice (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Explicit_Dereference (Loc,
New_Reference_To (Defining_Identifier (Old_TSD), Loc)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Tags_Table), Loc)),
Discrete_Range => Make_Range (Loc,
Make_Integer_Literal (Loc, Uint_0),
Make_Integer_Literal (Loc, I_Depth - 1))))));
-- Copy the table of interfaces of the parent
-- if not System."=" (TSD (Old_Tag).Ifaces_Table_Ptr,
-- System.Null_Address)
-- then
-- New_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces):=
-- Old_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces);
-- end if;
-- The table of interfaces is not available under certified run-time
if RTE_Record_Component_Available (RE_Nb_Ifaces) then
Append_To (L,
Make_If_Statement (Loc,
Condition =>
Make_Op_Not (Loc,
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
Prefix =>
Make_Explicit_Dereference (Loc,
New_Reference_To
(Defining_Identifier (Old_TSD), Loc)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Ifaces_Table_Ptr),
Loc)),
Right_Opnd =>
New_Reference_To (RTE (RE_Null_Address), Loc))),
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
Name =>
Make_Slice (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Build_Iface_Table_Ptr
(New_Reference_To
(Defining_Identifier (New_TSD), Loc)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Ifaces_Table), Loc)),
Discrete_Range => Make_Range (Loc,
Make_Integer_Literal (Loc, Uint_1),
Make_Integer_Literal (Loc, Parent_Num_Ifaces))),
Expression =>
Make_Slice (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Build_Iface_Table_Ptr
(New_Reference_To
(Defining_Identifier (Old_TSD), Loc)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Ifaces_Table), Loc)),
Discrete_Range => Make_Range (Loc,
Make_Integer_Literal (Loc, Uint_1),
Make_Integer_Literal (Loc, Parent_Num_Ifaces)))))));
end if;
-- TSD (New_Tag).Tags_Table (0) := New_Tag;
Append_To (L,
Make_Assignment_Statement (Loc,
Name =>
Make_Indexed_Component (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Explicit_Dereference (Loc,
New_Reference_To
(Defining_Identifier (New_TSD), Loc)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Tags_Table), Loc)),
Expressions =>
New_List (Make_Integer_Literal (Loc, Uint_0))),
Expression => New_Tag_Node));
-- At the end of the Access_Disp_Table list we have the type
-- declaration required to convert the tag into a pointer to
-- the prims_ptr table (see Freeze_Record_Type).
return
Make_Block_Statement (Loc,
Declarations => New_List (
Old_TSD,
New_TSD),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, L));
Make_Indexed_Component (Loc,
Prefix =>
Unchecked_Convert_To
(Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node),
Expressions => New_List (Make_Integer_Literal (Loc, Position)));
end Build_Get_Prim_Op_Address;
end Build_Inherit_TSD;
-----------------------------
-- Build_Get_Transportable --
-----------------------------
-------------------------
-- Build_Predefined_DT --
-------------------------
function Build_Predefined_DT
function Build_Get_Transportable
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id
is
begin
return
Unchecked_Convert_To (RTE_Tag_Node,
Make_Function_Call (Loc,
Name =>
Make_Expanded_Name (Loc,
Chars => Name_Op_Subtract,
Prefix =>
New_Reference_To (RTU_Entity (System_Storage_Elements), Loc),
Selector_Name =>
Make_Identifier (Loc,
Chars => Name_Op_Subtract)),
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Transportable), Loc));
end Build_Get_Transportable;
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
New_Reference_To (RTE (RE_DT_Prologue_Size), Loc))));
end Build_Predefined_DT;
------------------------------------
-- Build_Inherit_Predefined_Prims --
------------------------------------
----------------------------
-- Build_Set_External_Tag --
----------------------------
function Build_Set_External_Tag
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Value_Node : Node_Id) return Node_Id
function Build_Inherit_Predefined_Prims
(Loc : Source_Ptr;
Old_Tag_Node : Node_Id;
New_Tag_Node : Node_Id) return Node_Id
is
begin
return
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RO_TA_External_Tag), Loc)),
Make_Assignment_Statement (Loc,
Name =>
Make_Slice (Loc,
Prefix =>
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
Make_Selected_Component (Loc,
Prefix =>
Build_DT (Loc, New_Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Predef_Prims), Loc)))),
Discrete_Range => Make_Range (Loc,
Make_Integer_Literal (Loc, Uint_1),
New_Reference_To (RTE (RE_Default_Prim_Op_Count), Loc))),
Expression =>
Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Value_Node));
end Build_Set_External_Tag;
Expression =>
Make_Slice (Loc,
Prefix =>
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
Make_Selected_Component (Loc,
Prefix =>
Build_DT (Loc, Old_Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Predef_Prims), Loc)))),
Discrete_Range =>
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 1),
High_Bound =>
New_Reference_To (RTE (RE_Default_Prim_Op_Count), Loc))));
end Build_Inherit_Predefined_Prims;
------------------------
-- Build_Predef_Prims --
------------------------
function Build_Predef_Prims
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id
is
begin
return
Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Addr_Ptr),
Make_Function_Call (Loc,
Name =>
Make_Expanded_Name (Loc,
Chars => Name_Op_Subtract,
Prefix =>
New_Reference_To
(RTU_Entity (System_Storage_Elements), Loc),
Selector_Name =>
Make_Identifier (Loc,
Chars => Name_Op_Subtract)),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
New_Reference_To (RTE (RE_DT_Predef_Prims_Offset),
Loc))))));
end Build_Predef_Prims;
------------------------------------------
-- Build_Set_Predefined_Prim_Op_Address --
------------------------------------------
function Build_Set_Predefined_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id;
Address_Node : Node_Id) return Node_Id
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position : Uint;
Address_Node : Node_Id) return Node_Id
is
begin
return
Make_Assignment_Statement (Loc,
Name => Build_Get_Predefined_Prim_Op_Address
(Loc, Tag_Node, Position_Node),
Name => Build_Get_Predefined_Prim_Op_Address (Loc,
Tag_Node, Position),
Expression => Address_Node);
end Build_Set_Predefined_Prim_Op_Address;
@ -591,52 +430,20 @@ package body Exp_Atag is
-------------------------------
function Build_Set_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id;
Address_Node : Node_Id) return Node_Id
(Loc : Source_Ptr;
Typ : Entity_Id;
Tag_Node : Node_Id;
Position : Uint;
Address_Node : Node_Id) return Node_Id
is
begin
return
Make_Assignment_Statement (Loc,
Name => Build_Get_Prim_Op_Address (Loc,
Tag_Node, Position_Node),
Expression => Address_Node);
Make_Assignment_Statement (Loc,
Name => Build_Get_Prim_Op_Address
(Loc, Typ, Tag_Node, Position),
Expression => Address_Node);
end Build_Set_Prim_Op_Address;
-------------------
-- Build_Set_TSD --
-------------------
function Build_Set_TSD
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Value_Node : Node_Id) return Node_Id
is
begin
return
Make_Assignment_Statement (Loc,
Name =>
Make_Explicit_Dereference (Loc,
Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr),
Make_Function_Call (Loc,
Name =>
Make_Expanded_Name (Loc,
Chars => Name_Op_Subtract,
Prefix =>
New_Reference_To
(RTU_Entity (System_Storage_Elements), Loc),
Selector_Name =>
Make_Identifier (Loc,
Chars => Name_Op_Subtract)),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
Build_Typeinfo_Offset (Loc))))),
Expression => Value_Node);
end Build_Set_TSD;
---------------
-- Build_TSD --
---------------
@ -647,42 +454,21 @@ package body Exp_Atag is
Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr),
Make_Explicit_Dereference (Loc,
Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr),
Make_Function_Call (Loc,
Name =>
Make_Expanded_Name (Loc,
Chars => Name_Op_Subtract,
Prefix =>
New_Reference_To
(RTU_Entity (System_Storage_Elements), Loc),
Selector_Name =>
Make_Identifier (Loc,
Chars => Name_Op_Subtract)),
Make_Function_Call (Loc,
Name =>
Make_Expanded_Name (Loc,
Chars => Name_Op_Subtract,
Prefix =>
New_Reference_To
(RTU_Entity (System_Storage_Elements), Loc),
Selector_Name =>
Make_Identifier (Loc,
Chars => Name_Op_Subtract)),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
Build_Typeinfo_Offset (Loc))))));
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
New_Reference_To
(RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))));
end Build_TSD;
---------------------------
-- Build_Typeinfo_Offset --
---------------------------
function Build_Typeinfo_Offset (Loc : Source_Ptr) return Node_Id is
begin
return New_Reference_To (RTE (RE_DT_Typeinfo_Ptr_Size), Loc);
end Build_Typeinfo_Offset;
---------------
-- Tag_Node --
---------------
function RTE_Tag_Node return Entity_Id is
E : constant Entity_Id := RTE (RE_Tag);
begin
if Atree.Present (Full_View (E)) then
return Full_View (E);
else
return E;
end if;
end RTE_Tag_Node;
end Exp_Atag;

132
gcc/ada/exp_atag.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2006, Free Software Foundation, Inc. --
-- Copyright (C) 2006-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -28,18 +28,24 @@
-- subprograms of package Ada.Tags
with Types; use Types;
with Uintp; use Uintp;
package Exp_Atag is
procedure Build_Common_Dispatching_Select_Statements
(Loc : Source_Ptr;
DT_Ptr : Entity_Id;
Stmts : List_Id);
-- Ada 2005 (AI-345): Generate statements that are common between timed,
-- asynchronous, and conditional select expansion.
function Build_CW_Membership
(Loc : Source_Ptr;
Obj_Tag_Node : Node_Id;
Typ_Tag_Node : Node_Id) return Node_Id;
-- Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each
-- dispatch table contains a reference to a table of ancestors (stored
-- in the first part of the Tags_Table) and a count of the level of
-- inheritance "Idepth". Obj is in Typ'Class if Typ'Tag is in the table
-- of ancestors that are contained in the dispatch table referenced by
-- Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each DT
-- has a table of ancestors and its inheritance level (Idepth). Obj is in
-- Typ'Class if Typ'Tag is found in the table of ancestors referenced by
-- Obj'Tag. Knowing the level of inheritance of both types, this can be
-- computed in constant time by the formula:
--
@ -54,9 +60,9 @@ package Exp_Atag is
-- Generates: TSD (Tag).Access_Level
function Build_Get_Predefined_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id) return Node_Id;
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position : Uint) return Node_Id;
-- Given a pointer to a dispatch table (T) and a position in the DT, build
-- code that gets the address of the predefined virtual function stored in
-- it (used for dispatching calls).
@ -64,29 +70,22 @@ package Exp_Atag is
-- Generates: Predefined_DT (Tag).D (Position);
function Build_Get_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id) return Node_Id;
(Loc : Source_Ptr;
Typ : Entity_Id;
Tag_Node : Node_Id;
Position : Uint) return Node_Id;
-- Build code that retrieves the address of the virtual function stored in
-- a given position of the dispatch table (used for dispatching calls).
--
-- Generates: To_Tag (Tag).D (Position);
function Build_Get_RC_Offset
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id;
-- Build code that retrieves the Offset of the implicit record controller
-- when the object has controlled components. O otherwise.
function Build_Get_Transportable
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id;
-- Build code that retrieves the value of the Transportable flag for
-- the given Tag.
--
-- Generates: TSD (T).RC_Offset;
function Build_Get_Remotely_Callable
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id;
-- Build code that retrieves the value previously saved by Set_Remotely
-- Callable
--
-- Generates: TSD (Tag).Remotely_Callable
-- Generates: TSD (Tag).Transportable;
function Build_Inherit_Predefined_Prims
(Loc : Source_Ptr;
@ -96,6 +95,8 @@ package Exp_Atag is
--
-- Generates: Predefined_DT (New_T).D (All_Predefined_Prims) :=
-- Predefined_DT (Old_T).D (All_Predefined_Prims);
--
-- Required to build the dispatch tables with the 3.4 backend.
function Build_Inherit_Prims
(Loc : Source_Ptr;
@ -103,80 +104,39 @@ package Exp_Atag is
New_Tag_Node : Node_Id;
Num_Prims : Nat) return Node_Id;
-- Build code that inherits Num_Prims user-defined primitives from the
-- dispatch table of the parent type.
-- dispatch table of the parent type. It is used to copy the dispatch
-- table of the parent in case of derivations of CPP_Class types.
--
-- Generates:
-- New_Tag.Prims_Ptr (1 .. Num_Prims) :=
-- Old_Tag.Prims_Ptr (1 .. Num_Prims);
function Build_Inherit_TSD
(Loc : Source_Ptr;
Old_Tag_Node : Node_Id;
New_Tag_Node : Node_Id;
I_Depth : Nat;
Parent_Num_Ifaces : Nat) return Node_Id;
-- Generates code that initializes the TSD of a type knowing the tag,
-- inheritance depth, and number of interface types of the parent type.
--
-- Generates:
-- -- Copy the table of ancestors of the parent
--
-- TSD (New_Tag).Tags_Table (1 .. I_Depth) :=
-- TSD (Old_Tag).Tags_Table (0 .. I_Depth - 1);
--
-- -- Copy the table of interfaces of the parent
--
-- if TSD (Old_Tag).Ifaces_Table_Ptr /= null then
-- New_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces):=
-- Old_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces);
-- end if;
--
-- TSD (New_Tag).Tags_Table (0) := New_Tag;
function Build_New_TSD
(Loc : Source_Ptr;
New_Tag_Node : Node_Id) return List_Id;
-- Build code that initializes the TSD of a root type.
-- Generates: TSD (New_Tag).Tags_Table (0) := New_Tag;
function Build_Set_External_Tag
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Value_Node : Node_Id) return Node_Id;
-- Build code that saves the address of the string containing the external
-- tag in the dispatch table.
--
-- Generates: TSD (Tag).External_Tag := Cstring_Ptr! (Value);
function Build_Set_Predefined_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id;
Address_Node : Node_Id) return Node_Id;
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position : Uint;
Address_Node : Node_Id) return Node_Id;
-- Build code that saves the address of a virtual function in a given
-- Position of the portion of the dispatch table associated with the
-- predefined primitives of Tag (used for overriding).
-- predefined primitives of Tag. Called from Exp_Disp.Fill_DT_Entry
-- and Exp_Disp.Fill_Secondary_DT_Entry. It is used for:
-- 1) Filling the dispatch table of CPP_Class types.
-- 2) Late overriding (see Check_Dispatching_Operation).
--
-- Generates: Predefined_DT (Tag).D (Position) := Value
function Build_Set_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id;
Address_Node : Node_Id) return Node_Id;
(Loc : Source_Ptr;
Typ : Entity_Id;
Tag_Node : Node_Id;
Position : Uint;
Address_Node : Node_Id) return Node_Id;
-- Build code that saves the address of a virtual function in a given
-- Position of the dispatch table associated with the Tag (used for
-- overriding).
-- Position of the dispatch table associated with the Tag. Called from
-- Exp_Disp.Fill_DT_Entry and Exp_Disp.Fill_Secondary_DT_Entry. Used for:
-- 1) Filling the dispatch table of CPP_Class types.
-- 2) Late overriding (see Check_Dispatching_Operation).
--
-- Generates: Tag.D (Position) := Value
function Build_Set_TSD
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Value_Node : Node_Id) return Node_Id;
-- Build code that saves the address of the record containing the Type
-- Specific Data generated by GNAT.
--
-- Generates: To_Addr_Ptr (To_Address (Tag) - K_Typeinfo).all := Value
end Exp_Atag;

4340
gcc/ada/exp_disp.adb
View File

File diff suppressed because it is too large Load Diff

101
gcc/ada/exp_disp.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -111,7 +111,7 @@ package Exp_Disp is
-- interfaces, not generated for the rest of the cases. See Expand_N_
-- Timed_Entry_Call for more information.
-- Lifecycle of predefined primitive operations
-- Life cycle of predefined primitive operations
-- The specifications and bodies of the PPOs are created by
-- Make_Predefined_Primitive_Specs and Predefined_Primitive_Bodies
@ -122,16 +122,14 @@ package Exp_Disp is
-- PPOs are collected and added to the Primitive_Operations list of
-- a type by the regular analysis mechanism.
-- PPOs are frozen in Predefined_Primitive_Freeze in Exp_Ch3.
-- PPOs are frozen by Exp_Ch3.Predefined_Primitive_Freeze.
-- Thunks for PPOs are created in Freeze_Subprogram in Exp_Ch6, by a
-- call to Register_Predefined_DT_Entry, also in Exp_Ch6.
-- Thunks for PPOs are created by Make_DT.
-- Dispatch table positions of PPOs are set in Set_All_DT_Position in
-- Exp_Disp.
-- Dispatch table positions of PPOs are set by Set_All_DT_Position.
-- Calls to PPOs procede as regular dispatching calls. If the PPO
-- has a thunk, a call procedes as a regular dispatching call with
-- Calls to PPOs proceed as regular dispatching calls. If the PPO
-- has a thunk, a call proceeds as a regular dispatching call with
-- a thunk.
-- Guidelines for addition of new predefined primitive operations
@ -167,21 +165,6 @@ package Exp_Disp is
-- Exp_Disp.Default_Prim_Op_Position - indirect use
-- Exp_Disp.Set_All_DT_Position - direct use
type DT_Access_Action is
(IW_Membership,
Get_Entry_Index,
Get_Prim_Op_Kind,
Get_Tagged_Kind,
Register_Interface_Tag,
Register_Tag,
Set_Entry_Index,
Set_Offset_Index,
Set_OSD,
Set_Prim_Op_Kind,
Set_Signature,
Set_SSD,
Set_Tagged_Kind);
procedure Expand_Dispatching_Call (Call_Node : Node_Id);
-- Expand the call to the operation through the dispatch table and perform
-- the required tag checks when appropriate. For CPP types tag checks are
@ -198,41 +181,22 @@ package Exp_Disp is
-- the object to give access to the interface tag associated with the
-- secondary dispatch table.
function Expand_Interface_Thunk
procedure Expand_Interface_Thunk
(N : Node_Id;
Thunk_Alias : Node_Id;
Thunk_Id : Entity_Id) return Node_Id;
Thunk_Id : out Entity_Id;
Thunk_Code : out Node_Id);
-- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
-- generate additional subprograms (thunks) to have a layout compatible
-- with the C++ ABI. The thunk modifies the value of the first actual of
-- the call (that is, the pointer to the object) before transferring
-- control to the target function.
function Fill_DT_Entry
(Loc : Source_Ptr;
Prim : Entity_Id) return Node_Id;
-- Generate the code necessary to fill the appropriate entry of the
-- dispatch table of Prim's controlling type with Prim's address.
function Fill_Secondary_DT_Entry
(Loc : Source_Ptr;
Prim : Entity_Id;
Thunk_Id : Entity_Id;
Iface_DT_Ptr : Entity_Id) return Node_Id;
-- (Ada 2005): Generate the code necessary to fill the appropriate entry of
-- the secondary dispatch table of Prim's controlling type with Thunk_Id's
-- address.
function Make_DT_Access_Action
(Typ : Entity_Id;
Action : DT_Access_Action;
Args : List_Id) return Node_Id;
-- Generate a call to one of the Dispatch Table Access Subprograms defined
-- in Ada.Tags or in Interfaces.Cpp
--
-- Required in 3.4 case, why ??? giant comment needed for any gcc
-- specific code ???
function Make_DT (Typ : Entity_Id) return List_Id;
-- Expand the declarations for the Dispatch Table (or the Vtable in
-- the case of type whose ancestor is a CPP_Class)
-- Expand the declarations for the Dispatch Table.
function Make_Disp_Asynchronous_Select_Body
(Typ : Entity_Id) return Node_Id;
@ -284,8 +248,8 @@ package Exp_Disp is
function Make_Disp_Timed_Select_Body
(Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Generate the body of the primitive operation of type
-- Typ used for dispatching in timed selects. Generate a null body if Nul
-- is an interface type.
-- Typ used for dispatching in timed selects. Generates a body containing
-- a single null-statement if Typ is an interface type.
function Make_Disp_Timed_Select_Spec
(Typ : Entity_Id) return Node_Id;
@ -299,20 +263,19 @@ package Exp_Disp is
-- selects. Generate code to set the primitive operation kinds and entry
-- indices of primitive operations and primitive wrappers.
procedure Make_Secondary_DT
(Typ : Entity_Id;
Ancestor_Typ : Entity_Id;
Suffix_Index : Nat;
Iface : Entity_Id;
AI_Tag : Entity_Id;
Acc_Disp_Tables : in out Elist_Id;
Result : out List_Id);
-- Ada 2005 (AI-251): Expand the declarations for the Secondary Dispatch
-- Table of Typ associated with Iface (each abstract interface implemented
-- by Typ has a secondary dispatch table). The arguments Typ, Ancestor_Typ
-- and Suffix_Index are used to generate an unique external name which
-- is added at the end of Acc_Disp_Tables; this external name will be
-- used later by the subprogram Exp_Ch3.Build_Init_Procedure.
procedure Register_Primitive
(Loc : Source_Ptr;
Prim : Entity_Id;
Ins_Nod : Node_Id);
-- Register Prim in the corresponding primary or secondary dispatch table.
-- If Prim is associated with a secondary dispatch table then generate also
-- its thunk and register it in the associated secondary dispatch table.
-- In general the dispatch tables are always generated by Make_DT and
-- Make_Secondary_DT; this routine is only used in two corner cases:
-- 1) To construct the dispatch table of a tagged type whose parent
-- is a CPP_Class (see Build_Init_Procedure).
-- 2) To handle late overriding of dispatching operations (see
-- Check_Dispatching_Operation).
procedure Set_All_DT_Position (Typ : Entity_Id);
-- Set the DT_Position field for each primitive operation. In the CPP
@ -324,6 +287,12 @@ package Exp_Disp is
-- be the default constructor (i.e. the function returning this type,
-- having a pragma CPP_Constructor and no parameter)
procedure Set_DTC_Entity_Value
(Tagged_Type : Entity_Id;
Prim : Entity_Id);
-- Set the definite value of the DTC_Entity value associated with a given
-- primitive of a tagged type.
procedure Write_DT (Typ : Entity_Id);
pragma Export (Ada, Write_DT);
-- Debugging procedure (to be called within gdb)

64
gcc/ada/rtsfind.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -541,7 +541,15 @@ package body Rtsfind is
Output_Entity_Name (Id, "not available");
end if;
raise RE_Not_Available;
-- In configurable run time mode, we raise RE_Not_Available, and we hope
-- the caller deals gracefully with this. If we are in normal full run
-- time mode, a load failure is considered fatal and unrecoverable.
if Configurable_Run_Time_Mode then
raise RE_Not_Available;
else
raise Unrecoverable_Error;
end if;
end Load_Fail;
--------------
@ -683,12 +691,24 @@ package body Rtsfind is
Set_Analyzed (Cunit (Current_Sem_Unit), True);
if not Analyzed (Cunit (U.Unum)) then
Save_Private_Visibility;
Semantics (Cunit (U.Unum));
Restore_Private_Visibility;
if Fatal_Error (U.Unum) then
Load_Fail ("had semantic errors", U_Id, Id);
-- If the unit is already loaded through a limited_with clauses,
-- the relevant entities must already be available. We do not
-- want to load and analyze the unit because this would create
-- a real semantic dependence when the purpose of the limited_with
-- is precisely to avoid such.
if From_With_Type (Cunit_Entity (U.Unum)) then
null;
else
Save_Private_Visibility;
Semantics (Cunit (U.Unum));
Restore_Private_Visibility;
if Fatal_Error (U.Unum) then
Load_Fail ("had semantic errors", U_Id, Id);
end if;
end if;
end if;
@ -891,7 +911,8 @@ package body Rtsfind is
-----------------------
function Find_Local_Entity (E : RE_Id) return Entity_Id is
RE_Str : String renames RE_Id'Image (E);
RE_Str : constant String := RE_Id'Image (E);
Nam : Name_Id;
Ent : Entity_Id;
Save_Nam : constant String := Name_Buffer (1 .. Name_Len);
@ -902,7 +923,8 @@ package body Rtsfind is
Name_Buffer (1 .. Name_Len) :=
RE_Str (RE_Str'First + 3 .. RE_Str'Last);
Ent := Entity_Id (Get_Name_Table_Info (Name_Find));
Nam := Name_Find;
Ent := Entity_Id (Get_Name_Table_Info (Nam));
Name_Len := Save_Nam'Length;
Name_Buffer (1 .. Name_Len) := Save_Nam;
@ -956,9 +978,16 @@ package body Rtsfind is
pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration);
Ename := RE_Chars (E);
-- First we search the package entity chain
-- First we search the package entity chain. If the package
-- only has a limited view, scan the corresponding list of
-- incomplete types.
if From_With_Type (U.Entity) then
Pkg_Ent := First_Entity (Limited_View (U.Entity));
else
Pkg_Ent := First_Entity (U.Entity);
end if;
Pkg_Ent := First_Entity (U.Entity);
while Present (Pkg_Ent) loop
if Ename = Chars (Pkg_Ent) then
RE_Table (E) := Pkg_Ent;
@ -1067,6 +1096,7 @@ package body Rtsfind is
U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
E1 : Entity_Id;
Ename : Name_Id;
Found_E : Entity_Id;
Lib_Unit : Node_Id;
Pkg_Ent : Entity_Id;
@ -1103,13 +1133,15 @@ package body Rtsfind is
-- Search the entity in the components of record type declarations
-- found in the package entity chain.
Found_E := Empty;
Pkg_Ent := First_Entity (U.Entity);
Search : while Present (Pkg_Ent) loop
if Is_Record_Type (Pkg_Ent) then
E1 := First_Entity (Pkg_Ent);
while Present (E1) loop
if Ename = Chars (E1) then
exit Search;
pragma Assert (not Present (Found_E));
Found_E := E1;
end if;
Next_Entity (E1);
@ -1157,7 +1189,7 @@ package body Rtsfind is
end if;
Front_End_Inlining := Save_Front_End_Inlining;
return Check_CRT (E, E1);
return Check_CRT (E, Found_E);
end RTE_Record_Component;
------------------------------------
@ -1366,6 +1398,12 @@ package body Rtsfind is
end if;
end loop;
end if;
exception
-- Generate error message if run-time unit not available
when RE_Not_Available =>
Error_Msg_N ("& not available", Nam);
end Text_IO_Kludge;
end Rtsfind;

142
gcc/ada/rtsfind.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -184,6 +184,7 @@ package Rtsfind is
-- Children of System
System_Address_Image,
System_Arith_64,
System_AST_Handling,
System_Assertions,
@ -201,6 +202,7 @@ package Rtsfind is
System_Compare_Array_Unsigned_8,
System_DSA_Services,
System_Exception_Table,
System_Exceptions,
System_Exn_Int,
System_Exn_LLF,
System_Exn_LLI,
@ -399,7 +401,7 @@ package Rtsfind is
-- Range of values for children of Interfaces
subtype System_Child is RTU_Id
range System_Arith_64 .. System_Tasking_Stages;
range System_Address_Image .. System_Tasking_Stages;
-- Range of values for children or grandchildren of System
subtype System_Tasking_Child is System_Child
@ -456,11 +458,11 @@ package Rtsfind is
RE_Exception_Message, -- Ada.Exceptions
RE_Exception_Name_Simple, -- Ada.Exceptions
RE_Exception_Occurrence, -- Ada.Exceptions
RE_Local_Raise, -- Ada.Exceptions
RE_Null_Occurrence, -- Ada.Exceptions
RE_Poll, -- Ada.Exceptions
RE_Raise_Exception, -- Ada.Exceptions
RE_Raise_Exception_Always, -- Ada.Exceptions
RE_Raise_From_Controlled_Operation, -- Ada.Exceptions
RE_Reraise_Occurrence, -- Ada.Exceptions
RE_Reraise_Occurrence_Always, -- Ada.Exceptions
RE_Reraise_Occurrence_No_Defer, -- Ada.Exceptions
@ -485,42 +487,45 @@ package Rtsfind is
RE_Stream_Access, -- Ada.Streams.Stream_IO
RE_Abstract_Interface, -- Ada.Tags
RE_Access_Level, -- Ada.Tags
RE_Address_Array, -- Ada.Tags
RE_Addr_Ptr, -- Ada.Tags
RE_Base_Address, -- Ada.Tags
RE_Cstring_Ptr, -- Ada.Tags
RE_Default_Prim_Op_Count, -- Ada.Tags
RE_Descendant_Tag, -- Ada.Tags
RE_Dispatch_Table, -- Ada.Tags
RE_Dispatch_Table_Wrapper, -- Ada.Tags
RE_Displace, -- Ada.Tags
RE_DT_Entry_Size, -- Ada.Tags
RE_DT_Min_Prologue_Size, -- Ada.Tags
RE_DT_Prologue_Size, -- Ada.Tags
RE_DT, -- Ada.Tags
RE_DT_Predef_Prims_Offset, -- Ada.Tags
RE_DT_Typeinfo_Ptr_Size, -- Ada.Tags
RE_Expanded_Name, -- Ada.Tags
RE_External_Tag, -- Ada.Tags
RE_HT_Link, -- Ada.Tags
RO_TA_External_Tag, -- Ada.Tags
RE_Get_Access_Level, -- Ada.Tags
RE_Get_Entry_Index, -- Ada.Tags
RE_Get_Offset_Index, -- Ada.Tags
RE_Get_Predefined_Prim_Op_Address, -- Ada.Tags
RE_Get_Prim_Op_Address, -- Ada.Tags
RE_Get_Prim_Op_Kind, -- Ada.Tags
RE_Get_RC_Offset, -- Ada.Tags
RE_Get_Remotely_Callable, -- Ada.Tags
RE_Get_Tagged_Kind, -- Ada.Tags
RE_Idepth, -- Ada.Tags
RE_Iface_Tag, -- Ada.Tags
RE_Ifaces_Table, -- Ada.Tags
RE_Ifaces_Table_Ptr, -- Ada.Tags
RE_Interfaces_Table, -- Ada.Tags
RE_Interface_Data, -- Ada.Tags
RE_Interface_Data_Ptr, -- Ada.Tags
RE_Interface_Tag, -- Ada.Tags
RE_IW_Membership, -- Ada.Tags
RE_Nb_Ifaces, -- Ada.Tags
RE_No_Dispatch_Table_Wrapper, -- Ada.Tags
RE_NDT_Prims_Ptr, -- Ada.Tags
RE_NDT_TSD, -- Ada.Tags
RE_Num_Prims, -- Ada.Tags
RE_Object_Specific_Data, -- Ada.Tags
RE_Offset_To_Top, -- Ada.Tags
RE_Type_Specific_Data, -- Ada.Tags
RE_Offset_To_Top_Function_Ptr, -- Ada.Tags
RE_OSD_Table, -- Ada.Tags
RE_OSD_Num_Prims, -- Ada.Tags
RE_POK_Function, -- Ada.Tags
RE_POK_Procedure, -- Ada.Tags
RE_POK_Protected_Entry, -- Ada.Tags
@ -529,34 +534,29 @@ package Rtsfind is
RE_POK_Task_Entry, -- Ada.Tags
RE_POK_Task_Function, -- Ada.Tags
RE_POK_Task_Procedure, -- Ada.Tags
RE_Predef_Prims, -- Ada.Tags
RE_Predef_Prims_Table_Ptr, -- Ada.Tags
RE_Prim_Op_Kind, -- Ada.Tags
RE_Primary_DT, -- Ada.Tags
RE_Prims_Ptr, -- Ada.Tags
RE_Register_Interface_Tag, -- Ada.Tags
RE_Primary_DT, -- Ada.Tags
RE_Signature, -- Ada.Tags
RE_SSD, -- Ada.Tags
RE_TSD, -- Ada.Tags
RE_Type_Specific_Data, -- Ada.Tags
RE_Register_Tag, -- Ada.Tags
RE_Remotely_Callable, -- Ada.Tags
RE_Transportable, -- Ada.Tags
RE_RC_Offset, -- Ada.Tags
RE_Secondary_DT, -- Ada.Tags
RE_Select_Specific_Data, -- Ada.Tags
RE_Set_Access_Level, -- Ada.Tags
RE_Set_Entry_Index, -- Ada.Tags
RE_Set_Expanded_Name, -- Ada.Tags
RE_Set_Num_Prim_Ops, -- Ada.Tags
RE_Set_Offset_Index, -- Ada.Tags
RE_Set_Offset_To_Top, -- Ada.Tags
RE_Set_OSD, -- Ada.Tags
RE_Set_Predefined_Prim_Op_Address, -- Ada.Tags
RE_Set_Prim_Op_Address, -- Ada.Tags
RE_Set_Prim_Op_Kind, -- Ada.Tags
RE_Set_RC_Offset, -- Ada.Tags
RE_Set_Remotely_Callable, -- Ada.Tags
RE_Set_SSD, -- Ada.Tags
RE_Set_Signature, -- Ada.Tags
RE_Set_Tagged_Kind, -- Ada.Tags
RE_Set_TSD, -- Ada.Tags
RE_Static_Offset_To_Top, -- Ada.Tags
RE_Tag, -- Ada.Tags
RE_Tag_Error, -- Ada.Tags
RE_Tag_Kind, -- Ada.Tags
RE_Tag_Ptr, -- Ada.Tags
RE_Tag_Table, -- Ada.Tags
RE_Tags_Table, -- Ada.Tags
RE_Tagged_Kind, -- Ada.Tags
RE_Type_Specific_Data_Ptr, -- Ada.Tags
@ -599,6 +599,8 @@ package Rtsfind is
RE_Null_Address, -- System
RE_Priority, -- System
RE_Address_Image, -- System.Address_Image
RE_Add_With_Ovflo_Check, -- System.Arith_64
RE_Double_Divide, -- System.Arith_64
RE_Multiply_With_Ovflo_Check, -- System.Arith_64
@ -607,6 +609,7 @@ package Rtsfind is
RE_Create_AST_Handler, -- System.AST_Handling
RE_Assert_Failure, -- System.Assertions
RE_Raise_Assert_Failure, -- System.Assertions
RE_AST_Handler, -- System.Aux_DEC
@ -663,6 +666,8 @@ package Rtsfind is
RE_Register_Exception, -- System.Exception_Table
RE_Local_Raise, -- System.Exceptions
RE_Exn_Integer, -- System.Exn_Int
RE_Exn_Long_Long_Float, -- System.Exn_LLF
@ -1231,6 +1236,7 @@ package Rtsfind is
RE_Storage_Offset, -- System.Storage_Elements
RE_Storage_Array, -- System.Storage_Elements
RE_To_Address, -- System.Storage_Elements
RE_Dummy_Communication_Block, -- System.Storage_Elements
RE_Root_Storage_Pool, -- System.Storage_Pools
RE_Allocate_Any, -- System_Storage_Pools,
@ -1333,11 +1339,6 @@ package Rtsfind is
RE_Get_GNAT_Exception, -- System.Soft_Links
RE_Update_Exception, -- System.Soft_Links
RE_ATSD, -- System.Threads
RE_Thread_Body_Enter, -- System.Threads
RE_Thread_Body_Exceptional_Exit, -- System.Threads
RE_Thread_Body_Leave, -- System.Threads
RE_Bits_1, -- System.Unsigned_Types
RE_Bits_2, -- System.Unsigned_Types
RE_Bits_4, -- System.Unsigned_Types
@ -1563,11 +1564,11 @@ package Rtsfind is
RE_Exception_Message => Ada_Exceptions,
RE_Exception_Name_Simple => Ada_Exceptions,
RE_Exception_Occurrence => Ada_Exceptions,
RE_Local_Raise => Ada_Exceptions,
RE_Null_Occurrence => Ada_Exceptions,
RE_Poll => Ada_Exceptions,
RE_Raise_Exception => Ada_Exceptions,
RE_Raise_Exception_Always => Ada_Exceptions,
RE_Raise_From_Controlled_Operation => Ada_Exceptions,
RE_Reraise_Occurrence => Ada_Exceptions,
RE_Reraise_Occurrence_Always => Ada_Exceptions,
RE_Reraise_Occurrence_No_Defer => Ada_Exceptions,
@ -1592,42 +1593,45 @@ package Rtsfind is
RE_Stream_Access => Ada_Streams_Stream_IO,
RE_Abstract_Interface => Ada_Tags,
RE_Access_Level => Ada_Tags,
RE_Address_Array => Ada_Tags,
RE_Addr_Ptr => Ada_Tags,
RE_Base_Address => Ada_Tags,
RE_Cstring_Ptr => Ada_Tags,
RE_Default_Prim_Op_Count => Ada_Tags,
RE_Descendant_Tag => Ada_Tags,
RE_Dispatch_Table => Ada_Tags,
RE_Dispatch_Table_Wrapper => Ada_Tags,
RE_Displace => Ada_Tags,
RE_DT_Entry_Size => Ada_Tags,
RE_DT_Min_Prologue_Size => Ada_Tags,
RE_DT_Prologue_Size => Ada_Tags,
RE_DT => Ada_Tags,
RE_DT_Predef_Prims_Offset => Ada_Tags,
RE_DT_Typeinfo_Ptr_Size => Ada_Tags,
RE_Expanded_Name => Ada_Tags,
RE_External_Tag => Ada_Tags,
RE_HT_Link => Ada_Tags,
RO_TA_External_Tag => Ada_Tags,
RE_Get_Access_Level => Ada_Tags,
RE_Get_Entry_Index => Ada_Tags,
RE_Get_Offset_Index => Ada_Tags,
RE_Get_Predefined_Prim_Op_Address => Ada_Tags,
RE_Get_Prim_Op_Address => Ada_Tags,
RE_Get_Prim_Op_Kind => Ada_Tags,
RE_Get_RC_Offset => Ada_Tags,
RE_Get_Remotely_Callable => Ada_Tags,
RE_Get_Tagged_Kind => Ada_Tags,
RE_Idepth => Ada_Tags,
RE_Iface_Tag => Ada_Tags,
RE_Ifaces_Table => Ada_Tags,
RE_Ifaces_Table_Ptr => Ada_Tags,
RE_Interfaces_Table => Ada_Tags,
RE_Interface_Data => Ada_Tags,
RE_Interface_Data_Ptr => Ada_Tags,
RE_Interface_Tag => Ada_Tags,
RE_IW_Membership => Ada_Tags,
RE_Nb_Ifaces => Ada_Tags,
RE_No_Dispatch_Table_Wrapper => Ada_Tags,
RE_NDT_Prims_Ptr => Ada_Tags,
RE_NDT_TSD => Ada_Tags,
RE_Num_Prims => Ada_Tags,
RE_Object_Specific_Data => Ada_Tags,
RE_Offset_To_Top => Ada_Tags,
RE_Type_Specific_Data => Ada_Tags,
RE_Offset_To_Top_Function_Ptr => Ada_Tags,
RE_OSD_Table => Ada_Tags,
RE_OSD_Num_Prims => Ada_Tags,
RE_POK_Function => Ada_Tags,
RE_POK_Procedure => Ada_Tags,
RE_POK_Protected_Entry => Ada_Tags,
@ -1636,34 +1640,29 @@ package Rtsfind is
RE_POK_Task_Entry => Ada_Tags,
RE_POK_Task_Function => Ada_Tags,
RE_POK_Task_Procedure => Ada_Tags,
RE_Predef_Prims => Ada_Tags,
RE_Predef_Prims_Table_Ptr => Ada_Tags,
RE_Prim_Op_Kind => Ada_Tags,
RE_Primary_DT => Ada_Tags,
RE_Prims_Ptr => Ada_Tags,
RE_Register_Interface_Tag => Ada_Tags,
RE_Primary_DT => Ada_Tags,
RE_Signature => Ada_Tags,
RE_SSD => Ada_Tags,
RE_TSD => Ada_Tags,
RE_Type_Specific_Data => Ada_Tags,
RE_Register_Tag => Ada_Tags,
RE_Remotely_Callable => Ada_Tags,
RE_Transportable => Ada_Tags,
RE_RC_Offset => Ada_Tags,
RE_Secondary_DT => Ada_Tags,
RE_Select_Specific_Data => Ada_Tags,
RE_Set_Access_Level => Ada_Tags,
RE_Set_Entry_Index => Ada_Tags,
RE_Set_Expanded_Name => Ada_Tags,
RE_Set_Num_Prim_Ops => Ada_Tags,
RE_Set_Offset_Index => Ada_Tags,
RE_Set_Offset_To_Top => Ada_Tags,
RE_Set_OSD => Ada_Tags,
RE_Set_Predefined_Prim_Op_Address => Ada_Tags,
RE_Set_Prim_Op_Address => Ada_Tags,
RE_Set_Prim_Op_Kind => Ada_Tags,
RE_Set_RC_Offset => Ada_Tags,
RE_Set_Remotely_Callable => Ada_Tags,
RE_Set_SSD => Ada_Tags,
RE_Set_Signature => Ada_Tags,
RE_Set_Tagged_Kind => Ada_Tags,
RE_Set_TSD => Ada_Tags,
RE_Static_Offset_To_Top => Ada_Tags,
RE_Tag => Ada_Tags,
RE_Tag_Error => Ada_Tags,
RE_Tag_Kind => Ada_Tags,
RE_Tag_Ptr => Ada_Tags,
RE_Tag_Table => Ada_Tags,
RE_Tags_Table => Ada_Tags,
RE_Tagged_Kind => Ada_Tags,
RE_Type_Specific_Data_Ptr => Ada_Tags,
@ -1704,6 +1703,8 @@ package Rtsfind is
RE_Null_Address => System,
RE_Priority => System,
RE_Address_Image => System_Address_Image,
RE_Add_With_Ovflo_Check => System_Arith_64,
RE_Double_Divide => System_Arith_64,
RE_Multiply_With_Ovflo_Check => System_Arith_64,
@ -1712,6 +1713,7 @@ package Rtsfind is
RE_Create_AST_Handler => System_AST_Handling,
RE_Assert_Failure => System_Assertions,
RE_Raise_Assert_Failure => System_Assertions,
RE_AST_Handler => System_Aux_DEC,
@ -1768,6 +1770,8 @@ package Rtsfind is
RE_Register_Exception => System_Exception_Table,
RE_Local_Raise => System_Exceptions,
RE_Exn_Integer => System_Exn_Int,
RE_Exn_Long_Long_Float => System_Exn_LLF,
@ -2336,6 +2340,7 @@ package Rtsfind is
RE_Storage_Offset => System_Storage_Elements,
RE_Storage_Array => System_Storage_Elements,
RE_To_Address => System_Storage_Elements,
RE_Dummy_Communication_Block => System_Storage_Elements,
RE_Root_Storage_Pool => System_Storage_Pools,
RE_Allocate_Any => System_Storage_Pools,
@ -2438,11 +2443,6 @@ package Rtsfind is
RE_Get_GNAT_Exception => System_Soft_Links,
RE_Update_Exception => System_Soft_Links,
RE_ATSD => System_Threads,
RE_Thread_Body_Enter => System_Threads,
RE_Thread_Body_Exceptional_Exit => System_Threads,
RE_Thread_Body_Leave => System_Threads,
RE_Bits_1 => System_Unsigned_Types,
RE_Bits_2 => System_Unsigned_Types,
RE_Bits_4 => System_Unsigned_Types,
@ -2808,9 +2808,9 @@ package Rtsfind is
-- construct.
function RTE_Available (E : RE_Id) return Boolean;
-- Returns true if a call to RTE will succeed without raising an
-- exception and without generating an error message, i.e. if the
-- call will obtain the desired entity without any problems.
-- Returns true if a call to RTE will succeed without raising an exception
-- and without generating an error message, i.e. if the call will obtain
-- the desired entity without any problems.
function RTE_Record_Component (E : RE_Id) return Entity_Id;
-- Given the entity defined in the above tables, as identified by the