Skip to content

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

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
parent dc1f64ac
Showing with 991 additions and 1356 deletions
gcc/ada/a-tags.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -41,32 +41,40 @@ pragma Elaborate_All (System.HTable); ...@@ -41,32 +41,40 @@ pragma Elaborate_All (System.HTable);
package body Ada.Tags is package body Ada.Tags is
-- Object specific data types (see description in a-tags.ads) -----------------------
-- Local Subprograms --
-----------------------
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_Array is array (Positive range <>) of Positive; function Get_External_Tag (T : Tag) return System.Address;
-- Returns address of a null terminated string containing the external name
type Object_Specific_Data (Nb_Prim : Positive) is record function Is_Primary_DT (T : Tag) return Boolean;
OSD_Table : Object_Specific_Data_Array (1 .. Nb_Prim); -- Given a tag returns True if it has the signature of a primary dispatch
-- Table used in secondary DT to reference their counterpart in the -- table. This is Inline_Always since it is called from other Inline_
-- select specific data (in the TSD of the primary DT). This construct -- Always subprograms where we want no out of line code to be generated.
-- is used in the handling of dispatching triggers in select statements.
-- Nb_Prim is the number of non-predefined primitive operations.
end record;
-- Select specific data types 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_Element is record function OSD (T : Tag) return Object_Specific_Data_Ptr;
Index : Positive; -- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table,
Kind : Prim_Op_Kind; -- retrieve the address of the record containing the Object Specific
end record; -- Data table.
type Select_Specific_Data_Array is function SSD (T : Tag) return Select_Specific_Data_Ptr;
array (Positive range <>) of Select_Specific_Data_Element; -- 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.
type Select_Specific_Data (Nb_Prim : Positive) is record pragma Inline_Always (CW_Membership);
SSD_Table : Select_Specific_Data_Array (1 .. Nb_Prim); pragma Inline_Always (Get_External_Tag);
-- NOTE: Nb_Prim is the number of non-predefined primitive operations pragma Inline_Always (Is_Primary_DT);
end record; pragma Inline_Always (OSD);
pragma Inline_Always (SSD);
--------------------------------------------- ---------------------------------------------
-- Unchecked Conversions for String Fields -- -- Unchecked Conversions for String Fields --
...@@ -78,6 +86,17 @@ package body Ada.Tags is ...@@ -78,6 +86,17 @@ package body Ada.Tags is
function To_Cstring_Ptr is function To_Cstring_Ptr is
new Unchecked_Conversion (System.Address, Cstring_Ptr); 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 -- -- Unchecked Conversions for other components --
------------------------------------------------ ------------------------------------------------
...@@ -88,47 +107,93 @@ package body Ada.Tags is ...@@ -88,47 +107,93 @@ package body Ada.Tags is
function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size); function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size);
-- The profile of the implicitly defined _size primitive -- The profile of the implicitly defined _size primitive
type Offset_To_Top_Function_Ptr is -------------------------------
access function (This : System.Address) -- Inline_Always Subprograms --
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.
function To_Offset_To_Top_Function_Ptr is -- Inline_always subprograms must be placed before their first call to
new Unchecked_Conversion (System.Address, Offset_To_Top_Function_Ptr); -- 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 -- Canonical implementation of Classwide Membership corresponding to:
new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
----------------------- -- Obj in Typ'Class
-- Local Subprograms --
-----------------------
function Is_Primary_DT (T : Tag) return Boolean; -- Each dispatch table contains a reference to a table of ancestors (stored
pragma Inline_Always (Is_Primary_DT); -- in the first part of the Tags_Table) and a count of the level of
-- Given a tag returns True if it has the signature of a primary dispatch -- inheritance "Idepth".
-- 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.
function Length (Str : Cstring_Ptr) return Natural; -- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
-- Length of string represented by the given pointer (treating the string -- contained in the dispatch table referenced by Obj'Tag . Knowing the
-- as a C-style string, which is Nul terminated). -- 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
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;
----------------------
-- Get_External_Tag --
----------------------
function Predefined_DT (T : Tag) return Tag; function Get_External_Tag (T : Tag) return System.Address is
pragma Inline_Always (Predefined_DT); TSD_Ptr : constant Addr_Ptr :=
-- Displace the Tag to reference the dispatch table containing the To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
-- predefined primitives. 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;
function Typeinfo_Ptr (T : Tag) return System.Address; -------------------
-- Returns the current value of the typeinfo_ptr component available in -- Is_Primary_DT --
-- the prologue of the dispatch table. -------------------
pragma Unreferenced (Typeinfo_Ptr); function Is_Primary_DT (T : Tag) return Boolean is
-- These functions will be used for full compatibility with the C++ ABI 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 -- -- External_Tag_HTable --
...@@ -192,8 +257,12 @@ package body Ada.Tags is ...@@ -192,8 +257,12 @@ package body Ada.Tags is
----------------- -----------------
function Get_HT_Link (T : Tag) return Tag 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 begin
return TSD (T).HT_Link; return TSD.HT_Link;
end Get_HT_Link; end Get_HT_Link;
---------- ----------
...@@ -213,39 +282,16 @@ package body Ada.Tags is ...@@ -213,39 +282,16 @@ package body Ada.Tags is
----------------- -----------------
procedure Set_HT_Link (T : Tag; Next : Tag) 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 begin
TSD (T).HT_Link := Next; TSD.HT_Link := Next;
end Set_HT_Link; end Set_HT_Link;
end HTable_Subprograms; 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 -- -- Base_Address --
------------------ ------------------
...@@ -265,14 +311,18 @@ package body Ada.Tags is ...@@ -265,14 +311,18 @@ package body Ada.Tags is
is is
Iface_Table : Interface_Data_Ptr; Iface_Table : Interface_Data_Ptr;
Obj_Base : System.Address; Obj_Base : System.Address;
Obj_DT : Tag; Obj_DT : Dispatch_Table_Ptr;
Obj_TSD : Type_Specific_Data_Ptr; Obj_DT_Tag : Tag;
begin begin
Obj_Base := This - Offset_To_Top (This); if System."=" (This, System.Null_Address) then
Obj_DT := To_Tag_Ptr (Obj_Base).all; return System.Null_Address;
Obj_TSD := TSD (Obj_DT); end if;
Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
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 if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop for Id in 1 .. Iface_Table.Nb_Ifaces loop
...@@ -288,14 +338,11 @@ package body Ada.Tags is ...@@ -288,14 +338,11 @@ package body Ada.Tags is
-- to provide us with this value -- to provide us with this value
else else
Obj_Base := Obj_Base := Obj_Base +
Obj_Base + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func.all
To_Offset_To_Top_Function_Ptr (Obj_Base);
(Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func).all
(Obj_Base);
end if; end if;
Obj_DT := To_Tag_Ptr (Obj_Base).all;
return Obj_Base; return Obj_Base;
end if; end if;
end loop; end loop;
...@@ -304,7 +351,7 @@ package body Ada.Tags is ...@@ -304,7 +351,7 @@ package body Ada.Tags is
-- Check if T is an immediate ancestor. This is required to handle -- Check if T is an immediate ancestor. This is required to handle
-- conversion of class-wide interfaces to tagged types. -- 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; return Obj_Base;
end if; end if;
...@@ -313,6 +360,17 @@ package body Ada.Tags is ...@@ -313,6 +360,17 @@ package body Ada.Tags is
raise Constraint_Error; raise Constraint_Error;
end Displace; 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 -- -- IW_Membership --
------------------- -------------------
...@@ -329,20 +387,15 @@ package body Ada.Tags is ...@@ -329,20 +387,15 @@ package body Ada.Tags is
function IW_Membership (This : System.Address; T : Tag) return Boolean is function IW_Membership (This : System.Address; T : Tag) return Boolean is
Iface_Table : Interface_Data_Ptr; Iface_Table : Interface_Data_Ptr;
Last_Id : Natural;
Obj_Base : System.Address; Obj_Base : System.Address;
Obj_DT : Tag; Obj_DT : Dispatch_Table_Ptr;
Obj_TSD : Type_Specific_Data_Ptr; Obj_TSD : Type_Specific_Data_Ptr;
begin begin
Obj_Base := This - Offset_To_Top (This); Obj_Base := Base_Address (This);
Obj_DT := To_Tag_Ptr (Obj_Base).all; Obj_DT := DT (To_Tag_Ptr (Obj_Base).all);
Obj_TSD := TSD (Obj_DT); Obj_TSD := To_Type_Specific_Data_Ptr (Obj_DT.TSD);
Last_Id := Obj_TSD.Idepth; Iface_Table := Obj_TSD.Interfaces_Table;
-- Look for the tag in the table of interfaces
Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
if Iface_Table /= null then if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop for Id in 1 .. Iface_Table.Nb_Ifaces loop
...@@ -355,7 +408,7 @@ package body Ada.Tags is ...@@ -355,7 +408,7 @@ package body Ada.Tags is
-- Look for the tag in the ancestor tags table. This is required for: -- Look for the tag in the ancestor tags table. This is required for:
-- Iface_CW in Typ'Class -- 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 if Obj_TSD.Tags_Table (Id) = T then
return True; return True;
end if; end if;
...@@ -384,14 +437,18 @@ package body Ada.Tags is ...@@ -384,14 +437,18 @@ package body Ada.Tags is
------------------- -------------------
function Expanded_Name (T : Tag) return String 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 begin
if T = No_Tag then if T = No_Tag then
raise Tag_Error; raise Tag_Error;
end if; 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)); return Result (1 .. Length (Result));
end Expanded_Name; end Expanded_Name;
...@@ -400,14 +457,18 @@ package body Ada.Tags is ...@@ -400,14 +457,18 @@ package body Ada.Tags is
------------------ ------------------
function External_Tag (T : Tag) return String 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 begin
if T = No_Tag then if T = No_Tag then
raise Tag_Error; raise Tag_Error;
end if; 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)); return Result (1 .. Length (Result));
end External_Tag; end External_Tag;
...@@ -421,15 +482,6 @@ package body Ada.Tags is ...@@ -421,15 +482,6 @@ package body Ada.Tags is
end Get_Entry_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 -- -- Get_Prim_Op_Kind --
---------------------- ----------------------
...@@ -462,8 +514,12 @@ package body Ada.Tags is ...@@ -462,8 +514,12 @@ package body Ada.Tags is
------------------- -------------------
function Get_RC_Offset (T : Tag) return SSE.Storage_Offset 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 begin
return TSD (T).RC_Offset; return TSD.RC_Offset;
end Get_RC_Offset; end Get_RC_Offset;
--------------------- ---------------------
...@@ -471,10 +527,8 @@ package body Ada.Tags is ...@@ -471,10 +527,8 @@ package body Ada.Tags is
--------------------- ---------------------
function Get_Tagged_Kind (T : Tag) return Tagged_Kind is function Get_Tagged_Kind (T : Tag) return Tagged_Kind is
Tagged_Kind_Ptr : constant System.Address :=
To_Address (T) - K_Tagged_Kind;
begin begin
return To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all; return DT (T).Tag_Kind;
end Get_Tagged_Kind; end Get_Tagged_Kind;
----------------------------- -----------------------------
...@@ -482,11 +536,13 @@ package body Ada.Tags is ...@@ -482,11 +536,13 @@ package body Ada.Tags is
----------------------------- -----------------------------
function Interface_Ancestor_Tags (T : Tag) return Tag_Array 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 begin
Iface_Table := To_Interface_Data_Ptr (TSD (T).Ifaces_Table_Ptr);
if Iface_Table = null then if Iface_Table = null then
declare declare
Table : Tag_Array (1 .. 0); Table : Tag_Array (1 .. 0);
...@@ -510,17 +566,67 @@ package body Ada.Tags is ...@@ -510,17 +566,67 @@ package body Ada.Tags is
-- Internal_Tag -- -- 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 function Internal_Tag (External : String) return Tag is
Ext_Copy : aliased String (External'First .. External'Last + 1); Ext_Copy : aliased String (External'First .. External'Last + 1);
Res : Tag; Res : Tag := null;
begin begin
-- Make a copy of the string representing the external tag with -- Handle locally defined tagged types
-- a null at the end.
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 (External'Range) := External;
Ext_Copy (Ext_Copy'Last) := ASCII.NUL; Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
Res := External_Tag_HTable.Get (Ext_Copy'Address); Res := External_Tag_HTable.Get (Ext_Copy'Address);
end if;
if Res = null then if Res = null then
declare declare
...@@ -546,32 +652,30 @@ package body Ada.Tags is ...@@ -546,32 +652,30 @@ package body Ada.Tags is
(Descendant : Tag; (Descendant : Tag;
Ancestor : Tag) return Boolean Ancestor : Tag) return Boolean
is 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 begin
return CW_Membership (Descendant, Ancestor) 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; 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 -- -- Length --
------------ ------------
function Length (Str : Cstring_Ptr) return Natural is function Length (Str : Cstring_Ptr) return Natural is
Len : Integer := 1; Len : Integer;
begin begin
Len := 1;
while Str (Len) /= ASCII.Nul loop while Str (Len) /= ASCII.Nul loop
Len := Len + 1; Len := Len + 1;
end loop; end loop;
...@@ -584,31 +688,26 @@ package body Ada.Tags is ...@@ -584,31 +688,26 @@ package body Ada.Tags is
------------------- -------------------
function Offset_To_Top function Offset_To_Top
(This : System.Address) return System.Storage_Elements.Storage_Offset (This : System.Address) return SSE.Storage_Offset
is is
Curr_DT : constant Tag := To_Tag_Ptr (This).all; Tag_Size : constant SSE.Storage_Count :=
Offset_To_Top : Storage_Offset_Ptr; SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
begin
Offset_To_Top := To_Storage_Offset_Ptr
(To_Address (Curr_DT) - K_Offset_To_Top);
if Offset_To_Top.all = SSE.Storage_Offset'Last then
Offset_To_Top := To_Storage_Offset_Ptr (This + Tag_Size);
end if;
return Offset_To_Top.all; type Storage_Offset_Ptr is access SSE.Storage_Offset;
end Offset_To_Top; function To_Storage_Offset_Ptr is
new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
--------- Curr_DT : Dispatch_Table_Ptr;
-- 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 begin
return To_Object_Specific_Data_Ptr (OSD_Ptr.all); Curr_DT := DT (To_Tag_Ptr (This).all);
end OSD;
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;
end Offset_To_Top;
----------------- -----------------
-- Parent_Size -- -- Parent_Size --
...@@ -626,16 +725,28 @@ package body Ada.Tags is ...@@ -626,16 +725,28 @@ package body Ada.Tags is
-- The pointer to the _size primitive is always in the first slot of -- The pointer to the _size primitive is always in the first slot of
-- the dispatch table. -- the dispatch table.
Parent_Tag : Tag; TSD_Ptr : constant Addr_Ptr :=
-- The tag of the parent type through the dispatch table To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD : constant Type_Specific_Data_Ptr :=
F : Acc_Size; To_Type_Specific_Data_Ptr (TSD_Ptr.all);
-- Pointer to the TSD
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 -- Access to the _size primitive of the parent
begin 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 -- Here we compute the size of the _parent field of the object
return SSE.Storage_Count (F.all (Obj)); return SSE.Storage_Count (F.all (Obj));
...@@ -646,50 +757,29 @@ package body Ada.Tags is ...@@ -646,50 +757,29 @@ package body Ada.Tags is
---------------- ----------------
function Parent_Tag (T : Tag) return Tag is function Parent_Tag (T : Tag) return Tag is
TSD_Ptr : Addr_Ptr;
TSD : Type_Specific_Data_Ptr;
begin begin
if T = No_Tag then if T = No_Tag then
raise Tag_Error; raise Tag_Error;
end if; 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 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 -- 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 -- a type, but it's better to be explicit about returning No_Tag in
-- this case. -- this case.
if TSD (T).Idepth = 0 then if TSD.Idepth = 0 then
return No_Tag; return No_Tag;
else else
return TSD (T).Tags_Table (1); return TSD.Tags_Table (1);
end if; end if;
end Parent_Tag; end Parent_Tag;
-------------------
-- Predefined_DT --
-------------------
function Predefined_DT (T : Tag) return Tag is
begin
return To_Tag (To_Address (T) - DT_Prologue_Size);
end Predefined_DT;
----------------------------
-- Register_Interface_Tag --
----------------------------
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 -- -- Register_Tag --
------------------ ------------------
...@@ -712,86 +802,54 @@ package body Ada.Tags is ...@@ -712,86 +802,54 @@ package body Ada.Tags is
SSD (T).SSD_Table (Position).Index := Value; SSD (T).SSD_Table (Position).Index := Value;
end Set_Entry_Index; 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 -- -- Set_Offset_To_Top --
----------------------- -----------------------
procedure Set_Offset_To_Top procedure Set_Offset_To_Top
(This : System.Address; (This : System.Address;
Interface_T : Tag; Interface_T : Tag;
Is_Static : Boolean; Is_Static : Boolean;
Offset_Value : System.Storage_Elements.Storage_Offset; Offset_Value : SSE.Storage_Offset;
Offset_Func : System.Address) Offset_Func : Offset_To_Top_Function_Ptr)
is is
Prim_DT : Tag; Prim_DT : Dispatch_Table_Ptr;
Sec_Base : System.Address; Sec_Base : System.Address;
Sec_DT : Tag; Sec_DT : Dispatch_Table_Ptr;
Offset_To_Top : Storage_Offset_Ptr; Iface_Table : Interface_Data_Ptr;
Iface_Table : Interface_Data_Ptr;
Obj_TSD : Type_Specific_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. begin
-- Save the offset to top field in the secondary dispatch table
if Offset_Value /= 0 then if Offset_Value /= 0 then
Sec_Base := This + Offset_Value; Sec_Base := This + Offset_Value;
Sec_DT := To_Tag_Ptr (Sec_Base).all; Sec_DT := DT (To_Tag_Ptr (Sec_Base).all);
Offset_To_Top :=
To_Storage_Offset_Ptr (To_Address (Sec_DT) - K_Offset_To_Top);
if Is_Static then if Is_Static then
Offset_To_Top.all := Offset_Value; Sec_DT.Offset_To_Top := Offset_Value;
else else
Offset_To_Top.all := SSE.Storage_Offset'Last; Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last;
end if; end if;
end if; end if;
-- Save Offset_Value in the table of interfaces of the primary DT. This -- "This" points to the primary DT and we must save Offset_Value in
-- data will be used by the subprogram "Displace" to give support to -- the Offset_To_Top field of the corresponding secondary dispatch
-- backward abstract interface type conversions. -- table.
Prim_DT := DT (To_Tag_Ptr (This).all);
Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
Obj_TSD := TSD (Prim_DT); -- Save Offset_Value in the table of interfaces of the primary DT.
Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr); -- 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 -- Register the offset in the table of interfaces
if Iface_Table /= null then if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop for Id in 1 .. Iface_Table.Nb_Ifaces loop
if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then 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 if Is_Static then
Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value
...@@ -811,17 +869,6 @@ package body Ada.Tags is ...@@ -811,17 +869,6 @@ package body Ada.Tags is
raise Program_Error; raise Program_Error;
end Set_Offset_To_Top; 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 -- -- Set_Prim_Op_Kind --
---------------------- ----------------------
...@@ -835,70 +882,6 @@ package body Ada.Tags is ...@@ -835,70 +882,6 @@ package body Ada.Tags is
SSD (T).SSD_Table (Position).Kind := Value; SSD (T).SSD_Table (Position).Kind := Value;
end Set_Prim_Op_Kind; 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 -- -- Wide_Expanded_Name --
------------------------ ------------------------
......
gcc/ada/a-tags.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -37,7 +37,7 @@ ...@@ -37,7 +37,7 @@
with System; with System;
with System.Storage_Elements; with System.Storage_Elements;
with Unchecked_Conversion; with Ada.Unchecked_Conversion;
package Ada.Tags is package Ada.Tags is
pragma Preelaborate_05; pragma Preelaborate_05;
...@@ -84,17 +84,15 @@ private ...@@ -84,17 +84,15 @@ private
-- Structure of the GNAT Primary Dispatch Table -- Structure of the GNAT Primary Dispatch Table
-- +--------------------+ -- +--------------------+
-- | table of |
-- :predefined primitive:
-- | ops pointers |
-- +--------------------+
-- | Signature | -- | Signature |
-- +--------------------+ -- +--------------------+
-- | Tagged_Kind | -- | Tagged_Kind |
-- +--------------------+ -- +--------------------+ Predef Prims
-- | Offset_To_Top | -- | Predef_Prims -----------------------------> +------------+
-- +--------------------+ -- +--------------------+ | table of |
-- |Typeinfo_Ptr/TSD_Ptr---> Type Specific Data -- | Offset_To_Top | | predefined |
-- +--------------------+ | primitives |
-- |Typeinfo_Ptr/TSD_Ptr---> Type Specific Data +------------+
-- Tag ---> +--------------------+ +-------------------+ -- Tag ---> +--------------------+ +-------------------+
-- | table of | | inheritance depth | -- | table of | | inheritance depth |
-- : primitive ops : +-------------------+ -- : primitive ops : +-------------------+
...@@ -110,16 +108,14 @@ private ...@@ -110,16 +108,14 @@ private
-- +-------------------+ -- +-------------------+
-- | rec ctrler offset | -- | rec ctrler offset |
-- +-------------------+ -- +-------------------+
-- | num prim ops | -- | Ifaces_Table ---> Interface Data
-- +-------------------+
-- | Ifaces_Table_Ptr --> Interface Data
-- +-------------------+ +------------+ -- +-------------------+ +------------+
-- Select Specific Data <---- SSD_Ptr | | table | -- Select Specific Data <---- SSD | | Nb_Ifaces |
-- +------------------+ +-------------------+ : of : -- +------------------+ +-------------------+ +------------+
-- |table of primitive| | table of | | interfaces | -- |table of primitive| | table of | | table |
-- : operation : : ancestor : +------------+ -- : operation : : ancestor : : of :
-- | kinds | | tags | -- | kinds | | tags | | interfaces |
-- +------------------+ +-------------------+ -- +------------------+ +-------------------+ +------------+
-- |table of | -- |table of |
-- : entry : -- : entry :
-- | indices | -- | indices |
...@@ -148,77 +144,88 @@ private ...@@ -148,77 +144,88 @@ private
-- +---------------+ -- +---------------+
-- The runtime information kept for each tagged type is separated into two -- The runtime information kept for each tagged type is separated into two
-- objects: the Dispatch Table and the Type Specific Data record. These -- objects: the Dispatch Table and the Type Specific Data record.
-- two objects are allocated statically using the constants:
package SSE renames System.Storage_Elements;
-- 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;
subtype Cstring is String (Positive); subtype Cstring is String (Positive);
type Cstring_Ptr is access all Cstring; type Cstring_Ptr is access all Cstring;
pragma No_Strict_Aliasing (Cstring_Ptr); pragma No_Strict_Aliasing (Cstring_Ptr);
-- We suppress index checks because the declared size in the record below -- Declarations for the table of interfaces
-- is a dummy size of one (see below).
type Tag_Table is array (Natural range <>) of Tag; type Offset_To_Top_Function_Ptr is
pragma Suppress_Initialization (Tag_Table); access function (This : System.Address) return SSE.Storage_Offset;
pragma Suppress (Index_Check, On => Tag_Table); -- 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.
package SSE renames System.Storage_Elements; type Interface_Data_Element is record
Iface_Tag : Tag;
Static_Offset_To_Top : Boolean;
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 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 specific data types 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;
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.
-- 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.
type Prim_Op_Kind is
(POK_Function,
POK_Procedure,
POK_Protected_Entry,
POK_Protected_Function,
POK_Protected_Procedure,
POK_Task_Entry,
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 type Type_Specific_Data (Idepth : Natural) is record
-- Inheritance Depth Level: Used to implement the membership test -- The discriminant Idepth is the Inheritance Depth Level: Used to
-- associated with single inheritance of tagged types in constant-time. -- implement the membership test associated with single inheritance of
-- It also indicates the size of the Tags_Table component. -- tagged types in constant-time. It also indicates the size of the
-- Tags_Table component.
Access_Level : Natural; Access_Level : Natural;
-- Accessibility level required to give support to Ada 2005 nested type -- Accessibility level required to give support to Ada 2005 nested type
...@@ -232,22 +239,29 @@ private ...@@ -232,22 +239,29 @@ private
Expanded_Name : Cstring_Ptr; Expanded_Name : Cstring_Ptr;
External_Tag : Cstring_Ptr; External_Tag : Cstring_Ptr;
HT_Link : Tag; HT_Link : Tag;
-- Components used to support to the Ada.Tags subprograms in RM 3.9. -- Components used to support to the Ada.Tags subprograms in RM 3.9
-- Note: Expanded_Name is referenced by GDB ???
-- 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.
Remotely_Callable : Boolean; Transportable : Boolean;
-- Used to check ARM E.4 (18) -- 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; RC_Offset : SSE.Storage_Offset;
-- Controller Offset: Used to give support to tagged controlled objects -- Controller Offset: Used to give support to tagged controlled objects
-- (see Get_Deep_Controller at s-finimp) -- (see Get_Deep_Controller at s-finimp)
Ifaces_Table_Ptr : System.Address; Interfaces_Table : Interface_Data_Ptr;
-- Pointer to the table of interface tags. It is used to implement the -- Pointer to the table of interface tags. It is used to implement the
-- membership test associated with interfaces and also for backward -- membership test associated with interfaces and also for backward
-- abstract interface type conversions (Ada 2005:AI-251) -- abstract interface type conversions (Ada 2005:AI-251)
SSD_Ptr : System.Address; SSD : Select_Specific_Data_Ptr;
-- Pointer to a table of records used in dispatching selects. This -- Pointer to a table of records used in dispatching selects. This
-- field has a meaningful value for all tagged types that implement -- field has a meaningful value for all tagged types that implement
-- a limited, protected, synchronized or task interfaces and have -- a limited, protected, synchronized or task interfaces and have
...@@ -258,66 +272,14 @@ private ...@@ -258,66 +272,14 @@ private
-- depth level of the tagged type. -- depth level of the tagged type.
end record; end record;
-- Declarations for the table of interfaces
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;
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
-- 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 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; type Type_Specific_Data_Ptr is access all Type_Specific_Data;
No_Tag : constant Tag := null; -- Declarations for the dispatch table record
type Interface_Data_Ptr is access all Interface_Data; type Signature_Kind is
-- Table of abstract interfaces used to give support to backward interface (Unknown,
-- conversions and also to IW_Membership. Primary_DT,
Secondary_DT);
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.
type Prim_Op_Kind is
(POK_Function,
POK_Procedure,
POK_Protected_Entry,
POK_Protected_Function,
POK_Protected_Procedure,
POK_Task_Entry,
POK_Task_Function,
POK_Task_Procedure);
-- Tagged type kinds with respect to concurrency and limitedness -- Tagged type kinds with respect to concurrency and limitedness
...@@ -329,53 +291,66 @@ private ...@@ -329,53 +291,66 @@ private
TK_Tagged, TK_Tagged,
TK_Task); 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; 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 DT_Predef_Prims_Size : constant SSE.Storage_Count :=
(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 :=
SSE.Storage_Count SSE.Storage_Count
(2 * (Standard'Address_Size / (1 * (Standard'Address_Size /
System.Storage_Unit)); System.Storage_Unit));
-- Size of the hidden part of the dispatch table used when the program -- Size of the Predef_Prims field of the Dispatch_Table
-- 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
DT_Offset_To_Top_Size : constant SSE.Storage_Count := DT_Offset_To_Top_Size : constant SSE.Storage_Count :=
SSE.Storage_Count SSE.Storage_Count
...@@ -389,28 +364,27 @@ private ...@@ -389,28 +364,27 @@ private
System.Storage_Unit)); System.Storage_Unit));
-- Size of the Typeinfo_Ptr field of the Dispatch Table -- Size of the Typeinfo_Ptr field of the Dispatch Table
DT_Entry_Size : constant SSE.Storage_Count := use type System.Storage_Elements.Storage_Offset;
SSE.Storage_Count
(1 * (Standard'Address_Size / System.Storage_Unit)); DT_Predef_Prims_Offset : constant SSE.Storage_Count :=
-- Size of each primitive operation entry in the Dispatch Table DT_Typeinfo_Ptr_Size
+ DT_Offset_To_Top_Size
Tag_Size : constant SSE.Storage_Count := + DT_Predef_Prims_Size;
SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); -- Offset from Prims_Ptr to Predef_Prims component
-- Size of each tag
-- Object Specific Data record of secondary dispatch tables
-- Constants used by the code generated by the frontend to get access
-- to the header of the dispatch table. type Object_Specific_Data_Array is array (Positive range <>) of Positive;
K_Typeinfo : constant SSE.Storage_Count := DT_Typeinfo_Ptr_Size; type Object_Specific_Data (OSD_Num_Prims : Positive) is record
K_Offset_To_Top : constant SSE.Storage_Count := OSD_Table : Object_Specific_Data_Array (1 .. OSD_Num_Prims);
System.Storage_Elements."+" -- Table used in secondary DT to reference their counterpart in the
(K_Typeinfo, DT_Offset_To_Top_Size); -- select specific data (in the TSD of the primary DT). This construct
K_Tagged_Kind : constant SSE.Storage_Count := -- is used in the handling of dispatching triggers in select statements.
System.Storage_Elements."+" -- Nb_Prim is the number of non-predefined primitive operations.
(K_Offset_To_Top, DT_Tagged_Kind_Size); end record;
K_Signature : constant SSE.Storage_Count :=
System.Storage_Elements."+" type Object_Specific_Data_Ptr is access all Object_Specific_Data;
(K_Tagged_Kind, DT_Signature_Size);
-- The following subprogram specifications are placed here instead of -- The following subprogram specifications are placed here instead of
-- the package body to see them from the frontend through rtsfind. -- the package body to see them from the frontend through rtsfind.
...@@ -419,21 +393,17 @@ private ...@@ -419,21 +393,17 @@ private
-- Ada 2005 (AI-251): Displace "This" to point to the base address of -- 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). -- 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; function Displace (This : System.Address; T : Tag) return System.Address;
-- Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch -- Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch
-- table of T. -- 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; function Get_Entry_Index (T : Tag; Position : Positive) return Positive;
-- Ada 2005 (AI-251): Return a primitive operation's entry index (if entry) -- 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. -- 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 function Get_Offset_Index
(T : Tag; (T : Tag;
Position : Positive) return Positive; Position : Positive) return Positive;
...@@ -450,7 +420,7 @@ private ...@@ -450,7 +420,7 @@ private
function Get_RC_Offset (T : Tag) return SSE.Storage_Offset; function Get_RC_Offset (T : Tag) return SSE.Storage_Offset;
-- Return the Offset of the implicit record controller when the object -- 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"); pragma Export (Ada, Get_RC_Offset, "ada__tags__get_rc_offset");
-- This procedure is used in s-finimp to compute the deep routines -- This procedure is used in s-finimp to compute the deep routines
...@@ -477,17 +447,12 @@ private ...@@ -477,17 +447,12 @@ private
-- end Test; -- end Test;
function Offset_To_Top 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 -- 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 -- 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 -- of the tagged type has discriminants this value is stored in a record
-- component just immediately after the tag component. -- 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 function Parent_Size
(Obj : System.Address; (Obj : System.Address;
T : Tag) return SSE.Storage_Count; T : Tag) return SSE.Storage_Count;
...@@ -499,14 +464,6 @@ private ...@@ -499,14 +464,6 @@ private
pragma Export (Ada, Parent_Size, "ada__tags__parent_size"); pragma Export (Ada, Parent_Size, "ada__tags__parent_size");
-- This procedure is used in s-finimp and is thus exported manually -- 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); procedure Register_Tag (T : Tag);
-- Insert the Tag and its associated external_tag in a table for the -- Insert the Tag and its associated external_tag in a table for the
-- sake of Internal_Tag -- sake of Internal_Tag
...@@ -515,23 +472,12 @@ private ...@@ -515,23 +472,12 @@ private
-- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's -- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's
-- TSD table indexed by Position. -- 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 procedure Set_Offset_To_Top
(This : System.Address; (This : System.Address;
Interface_T : Tag; Interface_T : Tag;
Is_Static : Boolean; Is_Static : Boolean;
Offset_Value : System.Storage_Elements.Storage_Offset; Offset_Value : SSE.Storage_Offset;
Offset_Func : System.Address); Offset_Func : Offset_To_Top_Function_Ptr);
-- Ada 2005 (AI-251): Initialize the Offset_To_Top field in the prologue of -- 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 -- the dispatch table. In primary dispatch tables the value of "This" is
-- not required (and the compiler passes always the Null_Address value) and -- not required (and the compiler passes always the Null_Address value) and
...@@ -541,11 +487,6 @@ private ...@@ -541,11 +487,6 @@ private
-- distance from "This" to the object component containing the tag of the -- distance from "This" to the object component containing the tag of the
-- secondary dispatch table. -- 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 procedure Set_Prim_Op_Kind
(T : Tag; (T : Tag;
Position : Positive; Position : Positive;
...@@ -553,94 +494,52 @@ private ...@@ -553,94 +494,52 @@ private
-- Ada 2005 (AI-251): Set the kind of a primitive operation in T's TSD -- Ada 2005 (AI-251): Set the kind of a primitive operation in T's TSD
-- table indexed by Position. -- 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 -- Unchecked Conversions
type Addr_Ptr is access System.Address; Max_Predef_Prims : constant Natural := 16;
-- Compiler should check this constant is OK ???
type Signature_Values is subtype Predef_Prims_Table is Address_Array (1 .. Max_Predef_Prims);
array (1 .. DT_Signature_Size) of Signature_Kind; type Predef_Prims_Table_Ptr is access Predef_Prims_Table;
-- Type used to see the signature as a sequence of Signature_Kind values
type Signature_Values_Ptr is access all Signature_Values; type Addr_Ptr is access System.Address;
function To_Addr_Ptr is function To_Addr_Ptr is
new Unchecked_Conversion (System.Address, Addr_Ptr); new Ada.Unchecked_Conversion (System.Address, Addr_Ptr);
function To_Type_Specific_Data_Ptr is
new Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
function To_Address is function To_Address is
new Unchecked_Conversion (Tag, System.Address); new Ada.Unchecked_Conversion (Tag, System.Address);
function To_Interface_Data_Ptr is function To_Dispatch_Table_Ptr is
new Unchecked_Conversion (System.Address, Interface_Data_Ptr); new Ada.Unchecked_Conversion (Tag, Dispatch_Table_Ptr);
function To_Object_Specific_Data_Ptr is function To_Dispatch_Table_Ptr is
new Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr); new Ada.Unchecked_Conversion (System.Address, Dispatch_Table_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 function To_Object_Specific_Data_Ptr is
new Unchecked_Conversion (System.Address, new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr);
Signature_Values_Ptr);
function To_Tag is function To_Predef_Prims_Table_Ptr is
new Unchecked_Conversion (System.Address, Tag); new Ada.Unchecked_Conversion (System.Address, Predef_Prims_Table_Ptr);
function To_Tag_Ptr is 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 function To_Type_Specific_Data_Ptr is
new Unchecked_Conversion (System.Address, Tagged_Kind_Ptr); new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
-- Primitive dispatching operations are always inlined, to facilitate -- Primitive dispatching operations are always inlined, to facilitate use
-- use in a minimal/no run-time environment for high integrity use. -- in a minimal/no run-time environment for high integrity use.
pragma Inline_Always (CW_Membership);
pragma Inline_Always (Displace); pragma Inline_Always (Displace);
pragma Inline_Always (IW_Membership); pragma Inline_Always (IW_Membership);
pragma Inline_Always (Get_Entry_Index); pragma Inline_Always (Get_Entry_Index);
pragma Inline_Always (Get_Offset_Index); pragma Inline_Always (Get_Offset_Index);
pragma Inline_Always (Get_Prim_Op_Kind); pragma Inline_Always (Get_Prim_Op_Kind);
pragma Inline_Always (Get_Tagged_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 (Register_Tag);
pragma Inline_Always (Set_Entry_Index); 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_Offset_To_Top);
pragma Inline_Always (Set_Prim_Op_Kind); 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; end Ada.Tags;
gcc/ada/exp_atag.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -24,16 +24,15 @@ ...@@ -24,16 +24,15 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo; with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Nlists; use Nlists; with Nlists; use Nlists;
with Nmake; use Nmake; with Nmake; use Nmake;
with Rtsfind; use Rtsfind; with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo; with Stand; use Stand;
with Snames; use Snames; with Snames; use Snames;
with Tbuild; use Tbuild; with Tbuild; use Tbuild;
with Uintp; use Uintp;
package body Exp_Atag is package body Exp_Atag is
...@@ -41,33 +40,107 @@ package body Exp_Atag is ...@@ -41,33 +40,107 @@ package body Exp_Atag is
-- Local Subprograms -- -- Local Subprograms --
----------------------- -----------------------
function Build_Predefined_DT function Build_DT
(Loc : Source_Ptr; (Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id; Tag_Node : Node_Id) return Node_Id;
-- Build code that displaces the Tag to reference the dispatch table -- Build code that displaces the Tag to reference the base of the wrapper
-- containing the predefined primitives. -- record
-- --
-- Generates: To_Tag (To_Address (Tag_Node) - DT_Prologue_Size); -- Generates:
pragma Inline (Build_Predefined_DT); -- To_Dispatch_Table_Ptr
-- (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position);
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);
function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id; 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 -- Build code that retrieves the address of the record containing the Type
-- Specific Data generated by GNAT. -- Specific Data generated by GNAT.
-- --
-- Generate: To_Type_Specific_Data_Ptr -- Generate: To_Type_Specific_Data_Ptr
-- (To_Address_Ptr (To_Address (Tag) - Typeinfo_Offset).all); -- (To_Addr_Ptr (To_Address (Tag) - Typeinfo_Offset).all);
pragma Inline (Build_TSD);
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 --
------------------------------------------------
function RTE_Tag_Node return Entity_Id; procedure Build_Common_Dispatching_Select_Statements
-- Returns the entity associated with Ada.Tags.Tag (Loc : Source_Ptr;
pragma Inline (RTE_Tag_Node); 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 -- -- Build_CW_Membership --
...@@ -103,27 +176,42 @@ package body Exp_Atag is ...@@ -103,27 +176,42 @@ package body Exp_Atag is
begin begin
return return
Make_And_Then (Loc, Make_And_Then (Loc,
Left_Opnd => Left_Opnd =>
Make_Op_Ge (Loc, Make_Op_Ge (Loc,
Left_Opnd => Build_Pos, Left_Opnd => Build_Pos,
Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
Right_Opnd => Right_Opnd =>
Make_Op_Eq (Loc, Make_Op_Eq (Loc,
Left_Opnd => Left_Opnd =>
Make_Indexed_Component (Loc, Make_Indexed_Component (Loc,
Prefix => Prefix =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Obj_Tag_Node), Prefix => Build_TSD (Loc, Obj_Tag_Node),
Selector_Name => Selector_Name =>
New_Reference_To New_Reference_To
(RTE_Record_Component (RE_Tags_Table), Loc)), (RTE_Record_Component (RE_Tags_Table), Loc)),
Expressions => Expressions =>
New_List (Build_Pos)), New_List (Build_Pos)),
Right_Opnd => Typ_Tag_Node)); Right_Opnd => Typ_Tag_Node));
end Build_CW_Membership; 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 -- -- Build_Get_Access_Level --
---------------------------- ----------------------------
...@@ -146,125 +234,18 @@ package body Exp_Atag is ...@@ -146,125 +234,18 @@ package body Exp_Atag is
------------------------------------------ ------------------------------------------
function Build_Get_Predefined_Prim_Op_Address function Build_Get_Predefined_Prim_Op_Address
(Loc : Source_Ptr; (Loc : Source_Ptr;
Tag_Node : Node_Id; Tag_Node : Node_Id;
Position_Node : Node_Id) return Node_Id Position : Uint) 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
is is
begin begin
return return
Make_Indexed_Component (Loc, Make_Indexed_Component (Loc,
Prefix => Prefix =>
Make_Selected_Component (Loc, Build_Predef_Prims (Loc, Tag_Node),
Prefix => Expressions =>
Unchecked_Convert_To New_List (Make_Integer_Literal (Loc, Position)));
(RTE_Tag_Node, Tag_Node), end Build_Get_Predefined_Prim_Op_Address;
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_Inherit_Prims -- -- Build_Inherit_Prims --
...@@ -284,7 +265,7 @@ package body Exp_Atag is ...@@ -284,7 +265,7 @@ package body Exp_Atag is
Prefix => Prefix =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Prefix =>
Unchecked_Convert_To (RTE_Tag_Node, New_Tag_Node), Build_DT (Loc, New_Tag_Node),
Selector_Name => Selector_Name =>
New_Reference_To New_Reference_To
(RTE_Record_Component (RE_Prims_Ptr), Loc)), (RTE_Record_Component (RE_Prims_Ptr), Loc)),
...@@ -298,7 +279,7 @@ package body Exp_Atag is ...@@ -298,7 +279,7 @@ package body Exp_Atag is
Prefix => Prefix =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Prefix =>
Unchecked_Convert_To (RTE_Tag_Node, Old_Tag_Node), Build_DT (Loc, Old_Tag_Node),
Selector_Name => Selector_Name =>
New_Reference_To New_Reference_To
(RTE_Record_Component (RE_Prims_Ptr), Loc)), (RTE_Record_Component (RE_Prims_Ptr), Loc)),
...@@ -308,281 +289,139 @@ package body Exp_Atag is ...@@ -308,281 +289,139 @@ package body Exp_Atag is
High_Bound => Make_Integer_Literal (Loc, Num_Prims)))); High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
end Build_Inherit_Prims; end Build_Inherit_Prims;
------------------- -------------------------------
-- Build_New_TSD -- -- Build_Get_Prim_Op_Address --
------------------- -------------------------------
function Build_New_TSD function Build_Get_Prim_Op_Address
(Loc : Source_Ptr; (Loc : Source_Ptr;
New_Tag_Node : Node_Id) return List_Id Typ : Entity_Id;
Tag_Node : Node_Id;
Position : Uint) return Node_Id
is is
begin begin
return New_List ( pragma Assert
Make_Assignment_Statement (Loc, (Position <= DT_Entry_Count (First_Tag_Component (Typ)));
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))),
Expression => New_Tag_Node));
end Build_New_TSD;
----------------------- -- At the end of the Access_Disp_Table list we have the type
-- Build_Inherit_TSD -- -- declaration required to convert the tag into a pointer to
----------------------- -- the prims_ptr table (see Freeze_Record_Type).
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
---------------------------- return
-- Build_Iface_Table_Ptr -- Make_Indexed_Component (Loc,
---------------------------- Prefix =>
Unchecked_Convert_To
function Build_Iface_Table_Ptr (Tag_Node : Node_Id) return Node_Id is (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node),
begin Expressions => New_List (Make_Integer_Literal (Loc, Position)));
return end Build_Get_Prim_Op_Address;
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 -----------------------------
-- Build_Get_Transportable --
-----------------------------
function Build_Get_Transportable
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id
is
begin begin
Old_TSD := return
Make_Object_Declaration (Loc, Make_Selected_Component (Loc,
Defining_Identifier => Prefix => Build_TSD (Loc, Tag_Node),
Make_Defining_Identifier (Loc, New_Internal_Name ('T')), Selector_Name =>
Object_Definition => New_Reference_To
New_Reference_To (RTE (RE_Type_Specific_Data_Ptr), Loc), (RTE_Record_Component (RE_Transportable), Loc));
Expression => end Build_Get_Transportable;
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) := -- Build_Inherit_Predefined_Prims --
-- TSD (Old_Tag).Tags_Table (0 .. I_Depth - 1); ------------------------------------
Make_Assignment_Statement (Loc, function Build_Inherit_Predefined_Prims
Name => (Loc : Source_Ptr;
Make_Slice (Loc, Old_Tag_Node : Node_Id;
Prefix => New_Tag_Node : Node_Id) return Node_Id
Make_Selected_Component (Loc, is
Prefix => begin
Make_Explicit_Dereference (Loc, return
New_Reference_To (Defining_Identifier (New_TSD), Loc)), Make_Assignment_Statement (Loc,
Selector_Name => Name =>
New_Reference_To Make_Slice (Loc,
(RTE_Record_Component (RE_Tags_Table), Loc)), Prefix =>
Discrete_Range => Make_Range (Loc, Make_Explicit_Dereference (Loc,
Make_Integer_Literal (Loc, Uint_1), Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
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, Make_Selected_Component (Loc,
Prefix => Prefix =>
Make_Explicit_Dereference (Loc, Build_DT (Loc, New_Tag_Node),
New_Reference_To
(Defining_Identifier (New_TSD), Loc)),
Selector_Name => Selector_Name =>
New_Reference_To New_Reference_To
(RTE_Record_Component (RE_Tags_Table), Loc)), (RTE_Record_Component (RE_Predef_Prims), Loc)))),
Expressions => Discrete_Range => Make_Range (Loc,
New_List (Make_Integer_Literal (Loc, Uint_0))), Make_Integer_Literal (Loc, Uint_1),
New_Reference_To (RTE (RE_Default_Prim_Op_Count), Loc))),
Expression => New_Tag_Node));
return
Make_Block_Statement (Loc,
Declarations => New_List (
Old_TSD,
New_TSD),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, L));
end Build_Inherit_TSD; 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_Predefined_DT -- -- Build_Predef_Prims --
------------------------- ------------------------
function Build_Predefined_DT function Build_Predef_Prims
(Loc : Source_Ptr; (Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id Tag_Node : Node_Id) return Node_Id
is is
begin begin
return return
Unchecked_Convert_To (RTE_Tag_Node, Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
Make_Function_Call (Loc, Make_Explicit_Dereference (Loc,
Name => Unchecked_Convert_To (RTE (RE_Addr_Ptr),
Make_Expanded_Name (Loc, Make_Function_Call (Loc,
Chars => Name_Op_Subtract, Name =>
Prefix => Make_Expanded_Name (Loc,
New_Reference_To (RTU_Entity (System_Storage_Elements), Loc), Chars => Name_Op_Subtract,
Selector_Name => Prefix =>
Make_Identifier (Loc, New_Reference_To
Chars => Name_Op_Subtract)), (RTU_Entity (System_Storage_Elements), Loc),
Selector_Name =>
Parameter_Associations => New_List ( Make_Identifier (Loc,
Unchecked_Convert_To (RTE (RE_Address), Tag_Node), Chars => Name_Op_Subtract)),
New_Reference_To (RTE (RE_DT_Prologue_Size), Loc))));
end Build_Predefined_DT; Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
---------------------------- New_Reference_To (RTE (RE_DT_Predef_Prims_Offset),
-- Build_Set_External_Tag -- Loc))))));
---------------------------- end Build_Predef_Prims;
function Build_Set_External_Tag
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Value_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)),
Expression =>
Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Value_Node));
end Build_Set_External_Tag;
------------------------------------------ ------------------------------------------
-- Build_Set_Predefined_Prim_Op_Address -- -- Build_Set_Predefined_Prim_Op_Address --
------------------------------------------ ------------------------------------------
function Build_Set_Predefined_Prim_Op_Address function Build_Set_Predefined_Prim_Op_Address
(Loc : Source_Ptr; (Loc : Source_Ptr;
Tag_Node : Node_Id; Tag_Node : Node_Id;
Position_Node : Node_Id; Position : Uint;
Address_Node : Node_Id) return Node_Id Address_Node : Node_Id) return Node_Id
is is
begin begin
return return
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => Build_Get_Predefined_Prim_Op_Address Name => Build_Get_Predefined_Prim_Op_Address (Loc,
(Loc, Tag_Node, Position_Node), Tag_Node, Position),
Expression => Address_Node); Expression => Address_Node);
end Build_Set_Predefined_Prim_Op_Address; end Build_Set_Predefined_Prim_Op_Address;
...@@ -591,52 +430,20 @@ package body Exp_Atag is ...@@ -591,52 +430,20 @@ package body Exp_Atag is
------------------------------- -------------------------------
function Build_Set_Prim_Op_Address function Build_Set_Prim_Op_Address
(Loc : Source_Ptr; (Loc : Source_Ptr;
Tag_Node : Node_Id; Typ : Entity_Id;
Position_Node : Node_Id; Tag_Node : Node_Id;
Address_Node : Node_Id) return Node_Id Position : Uint;
Address_Node : Node_Id) return Node_Id
is is
begin begin
return return
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => Build_Get_Prim_Op_Address (Loc, Name => Build_Get_Prim_Op_Address
Tag_Node, Position_Node), (Loc, Typ, Tag_Node, Position),
Expression => Address_Node); Expression => Address_Node);
end Build_Set_Prim_Op_Address; 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 -- -- Build_TSD --
--------------- ---------------
...@@ -647,42 +454,21 @@ package body Exp_Atag is ...@@ -647,42 +454,21 @@ package body Exp_Atag is
Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr), Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr),
Make_Explicit_Dereference (Loc, Make_Explicit_Dereference (Loc,
Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr), Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr),
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => Name =>
Make_Expanded_Name (Loc, Make_Expanded_Name (Loc,
Chars => Name_Op_Subtract, Chars => Name_Op_Subtract,
Prefix => Prefix =>
New_Reference_To New_Reference_To
(RTU_Entity (System_Storage_Elements), Loc), (RTU_Entity (System_Storage_Elements), Loc),
Selector_Name => Selector_Name =>
Make_Identifier (Loc, Make_Identifier (Loc,
Chars => Name_Op_Subtract)), Chars => Name_Op_Subtract)),
Parameter_Associations => New_List ( Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Tag_Node), Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
Build_Typeinfo_Offset (Loc)))))); New_Reference_To
(RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))));
end Build_TSD; 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; end Exp_Atag;
gcc/ada/exp_atag.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -28,18 +28,24 @@ ...@@ -28,18 +28,24 @@
-- subprograms of package Ada.Tags -- subprograms of package Ada.Tags
with Types; use Types; with Types; use Types;
with Uintp; use Uintp;
package Exp_Atag is 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 function Build_CW_Membership
(Loc : Source_Ptr; (Loc : Source_Ptr;
Obj_Tag_Node : Node_Id; Obj_Tag_Node : Node_Id;
Typ_Tag_Node : Node_Id) return Node_Id; Typ_Tag_Node : Node_Id) return Node_Id;
-- Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each -- Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each DT
-- dispatch table contains a reference to a table of ancestors (stored -- has a table of ancestors and its inheritance level (Idepth). Obj is in
-- in the first part of the Tags_Table) and a count of the level of -- Typ'Class if Typ'Tag is found in the table of ancestors referenced by
-- 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 -- Obj'Tag. Knowing the level of inheritance of both types, this can be
-- computed in constant time by the formula: -- computed in constant time by the formula:
-- --
...@@ -54,9 +60,9 @@ package Exp_Atag is ...@@ -54,9 +60,9 @@ package Exp_Atag is
-- Generates: TSD (Tag).Access_Level -- Generates: TSD (Tag).Access_Level
function Build_Get_Predefined_Prim_Op_Address function Build_Get_Predefined_Prim_Op_Address
(Loc : Source_Ptr; (Loc : Source_Ptr;
Tag_Node : Node_Id; Tag_Node : Node_Id;
Position_Node : Node_Id) return Node_Id; Position : Uint) return Node_Id;
-- Given a pointer to a dispatch table (T) and a position in the DT, build -- 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 -- code that gets the address of the predefined virtual function stored in
-- it (used for dispatching calls). -- it (used for dispatching calls).
...@@ -64,29 +70,22 @@ package Exp_Atag is ...@@ -64,29 +70,22 @@ package Exp_Atag is
-- Generates: Predefined_DT (Tag).D (Position); -- Generates: Predefined_DT (Tag).D (Position);
function Build_Get_Prim_Op_Address function Build_Get_Prim_Op_Address
(Loc : Source_Ptr; (Loc : Source_Ptr;
Tag_Node : Node_Id; Typ : Entity_Id;
Position_Node : Node_Id) return Node_Id; Tag_Node : Node_Id;
Position : Uint) return Node_Id;
-- Build code that retrieves the address of the virtual function stored in -- Build code that retrieves the address of the virtual function stored in
-- a given position of the dispatch table (used for dispatching calls). -- a given position of the dispatch table (used for dispatching calls).
-- --
-- Generates: To_Tag (Tag).D (Position); -- Generates: To_Tag (Tag).D (Position);
function Build_Get_RC_Offset function Build_Get_Transportable
(Loc : Source_Ptr; (Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id; Tag_Node : Node_Id) return Node_Id;
-- Build code that retrieves the Offset of the implicit record controller -- Build code that retrieves the value of the Transportable flag for
-- when the object has controlled components. O otherwise. -- 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 function Build_Inherit_Predefined_Prims
(Loc : Source_Ptr; (Loc : Source_Ptr;
...@@ -96,6 +95,8 @@ package Exp_Atag is ...@@ -96,6 +95,8 @@ package Exp_Atag is
-- --
-- Generates: Predefined_DT (New_T).D (All_Predefined_Prims) := -- Generates: Predefined_DT (New_T).D (All_Predefined_Prims) :=
-- Predefined_DT (Old_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 function Build_Inherit_Prims
(Loc : Source_Ptr; (Loc : Source_Ptr;
...@@ -103,80 +104,39 @@ package Exp_Atag is ...@@ -103,80 +104,39 @@ package Exp_Atag is
New_Tag_Node : Node_Id; New_Tag_Node : Node_Id;
Num_Prims : Nat) return Node_Id; Num_Prims : Nat) return Node_Id;
-- Build code that inherits Num_Prims user-defined primitives from the -- 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: -- Generates:
-- New_Tag.Prims_Ptr (1 .. Num_Prims) := -- New_Tag.Prims_Ptr (1 .. Num_Prims) :=
-- Old_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 function Build_Set_Predefined_Prim_Op_Address
(Loc : Source_Ptr; (Loc : Source_Ptr;
Tag_Node : Node_Id; Tag_Node : Node_Id;
Position_Node : Node_Id; Position : Uint;
Address_Node : Node_Id) return Node_Id; Address_Node : Node_Id) return Node_Id;
-- Build code that saves the address of a virtual function in a given -- Build code that saves the address of a virtual function in a given
-- Position of the portion of the dispatch table associated with the -- 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 -- Generates: Predefined_DT (Tag).D (Position) := Value
function Build_Set_Prim_Op_Address function Build_Set_Prim_Op_Address
(Loc : Source_Ptr; (Loc : Source_Ptr;
Tag_Node : Node_Id; Typ : Entity_Id;
Position_Node : Node_Id; Tag_Node : Node_Id;
Address_Node : Node_Id) return Node_Id; Position : Uint;
Address_Node : Node_Id) return Node_Id;
-- Build code that saves the address of a virtual function in a given -- Build code that saves the address of a virtual function in a given
-- Position of the dispatch table associated with the Tag (used for -- Position of the dispatch table associated with the Tag. Called from
-- overriding). -- 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 -- 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; end Exp_Atag;
gcc/ada/exp_disp.adb
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/exp_disp.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -111,7 +111,7 @@ package Exp_Disp is ...@@ -111,7 +111,7 @@ package Exp_Disp is
-- interfaces, not generated for the rest of the cases. See Expand_N_ -- interfaces, not generated for the rest of the cases. See Expand_N_
-- Timed_Entry_Call for more information. -- 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 -- The specifications and bodies of the PPOs are created by
-- Make_Predefined_Primitive_Specs and Predefined_Primitive_Bodies -- Make_Predefined_Primitive_Specs and Predefined_Primitive_Bodies
...@@ -122,16 +122,14 @@ package Exp_Disp is ...@@ -122,16 +122,14 @@ package Exp_Disp is
-- PPOs are collected and added to the Primitive_Operations list of -- PPOs are collected and added to the Primitive_Operations list of
-- a type by the regular analysis mechanism. -- 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 -- Thunks for PPOs are created by Make_DT.
-- call to Register_Predefined_DT_Entry, also in Exp_Ch6.
-- Dispatch table positions of PPOs are set in Set_All_DT_Position in -- Dispatch table positions of PPOs are set by Set_All_DT_Position.
-- Exp_Disp.
-- Calls to PPOs procede as regular dispatching calls. If the PPO -- Calls to PPOs proceed as regular dispatching calls. If the PPO
-- has a thunk, a call procedes as a regular dispatching call with -- has a thunk, a call proceeds as a regular dispatching call with
-- a thunk. -- a thunk.
-- Guidelines for addition of new predefined primitive operations -- Guidelines for addition of new predefined primitive operations
...@@ -167,21 +165,6 @@ package Exp_Disp is ...@@ -167,21 +165,6 @@ package Exp_Disp is
-- Exp_Disp.Default_Prim_Op_Position - indirect use -- Exp_Disp.Default_Prim_Op_Position - indirect use
-- Exp_Disp.Set_All_DT_Position - direct use -- Exp_Disp.Set_All_DT_Position - direct use
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); procedure Expand_Dispatching_Call (Call_Node : Node_Id);
-- Expand the call to the operation through the dispatch table and perform -- Expand the call to the operation through the dispatch table and perform
-- the required tag checks when appropriate. For CPP types tag checks are -- the required tag checks when appropriate. For CPP types tag checks are
...@@ -198,41 +181,22 @@ package Exp_Disp is ...@@ -198,41 +181,22 @@ package Exp_Disp is
-- the object to give access to the interface tag associated with the -- the object to give access to the interface tag associated with the
-- secondary dispatch table. -- secondary dispatch table.
function Expand_Interface_Thunk procedure Expand_Interface_Thunk
(N : Node_Id; (N : Node_Id;
Thunk_Alias : 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 -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
-- generate additional subprograms (thunks) to have a layout compatible -- generate additional subprograms (thunks) to have a layout compatible
-- with the C++ ABI. The thunk modifies the value of the first actual of -- 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 -- the call (that is, the pointer to the object) before transferring
-- control to the target function. -- control to the target function.
--
function Fill_DT_Entry -- Required in 3.4 case, why ??? giant comment needed for any gcc
(Loc : Source_Ptr; -- specific code ???
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
function Make_DT (Typ : Entity_Id) return List_Id; function Make_DT (Typ : Entity_Id) return List_Id;
-- Expand the declarations for the Dispatch Table (or the Vtable in -- Expand the declarations for the Dispatch Table.
-- the case of type whose ancestor is a CPP_Class)
function Make_Disp_Asynchronous_Select_Body function Make_Disp_Asynchronous_Select_Body
(Typ : Entity_Id) return Node_Id; (Typ : Entity_Id) return Node_Id;
...@@ -284,8 +248,8 @@ package Exp_Disp is ...@@ -284,8 +248,8 @@ package Exp_Disp is
function Make_Disp_Timed_Select_Body function Make_Disp_Timed_Select_Body
(Typ : Entity_Id) return Node_Id; (Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Generate the body of the primitive operation of type -- 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 -- Typ used for dispatching in timed selects. Generates a body containing
-- is an interface type. -- a single null-statement if Typ is an interface type.
function Make_Disp_Timed_Select_Spec function Make_Disp_Timed_Select_Spec
(Typ : Entity_Id) return Node_Id; (Typ : Entity_Id) return Node_Id;
...@@ -299,20 +263,19 @@ package Exp_Disp is ...@@ -299,20 +263,19 @@ package Exp_Disp is
-- selects. Generate code to set the primitive operation kinds and entry -- selects. Generate code to set the primitive operation kinds and entry
-- indices of primitive operations and primitive wrappers. -- indices of primitive operations and primitive wrappers.
procedure Make_Secondary_DT procedure Register_Primitive
(Typ : Entity_Id; (Loc : Source_Ptr;
Ancestor_Typ : Entity_Id; Prim : Entity_Id;
Suffix_Index : Nat; Ins_Nod : Node_Id);
Iface : Entity_Id; -- Register Prim in the corresponding primary or secondary dispatch table.
AI_Tag : Entity_Id; -- If Prim is associated with a secondary dispatch table then generate also
Acc_Disp_Tables : in out Elist_Id; -- its thunk and register it in the associated secondary dispatch table.
Result : out List_Id); -- In general the dispatch tables are always generated by Make_DT and
-- Ada 2005 (AI-251): Expand the declarations for the Secondary Dispatch -- Make_Secondary_DT; this routine is only used in two corner cases:
-- Table of Typ associated with Iface (each abstract interface implemented -- 1) To construct the dispatch table of a tagged type whose parent
-- by Typ has a secondary dispatch table). The arguments Typ, Ancestor_Typ -- is a CPP_Class (see Build_Init_Procedure).
-- and Suffix_Index are used to generate an unique external name which -- 2) To handle late overriding of dispatching operations (see
-- is added at the end of Acc_Disp_Tables; this external name will be -- Check_Dispatching_Operation).
-- used later by the subprogram Exp_Ch3.Build_Init_Procedure.
procedure Set_All_DT_Position (Typ : Entity_Id); procedure Set_All_DT_Position (Typ : Entity_Id);
-- Set the DT_Position field for each primitive operation. In the CPP -- Set the DT_Position field for each primitive operation. In the CPP
...@@ -324,6 +287,12 @@ package Exp_Disp is ...@@ -324,6 +287,12 @@ package Exp_Disp is
-- be the default constructor (i.e. the function returning this type, -- be the default constructor (i.e. the function returning this type,
-- having a pragma CPP_Constructor and no parameter) -- 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); procedure Write_DT (Typ : Entity_Id);
pragma Export (Ada, Write_DT); pragma Export (Ada, Write_DT);
-- Debugging procedure (to be called within gdb) -- Debugging procedure (to be called within gdb)
......
gcc/ada/rtsfind.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -541,7 +541,15 @@ package body Rtsfind is ...@@ -541,7 +541,15 @@ package body Rtsfind is
Output_Entity_Name (Id, "not available"); Output_Entity_Name (Id, "not available");
end if; 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; end Load_Fail;
-------------- --------------
...@@ -683,12 +691,24 @@ package body Rtsfind is ...@@ -683,12 +691,24 @@ package body Rtsfind is
Set_Analyzed (Cunit (Current_Sem_Unit), True); Set_Analyzed (Cunit (Current_Sem_Unit), True);
if not Analyzed (Cunit (U.Unum)) then if not Analyzed (Cunit (U.Unum)) then
Save_Private_Visibility;
Semantics (Cunit (U.Unum));
Restore_Private_Visibility;
if Fatal_Error (U.Unum) then -- If the unit is already loaded through a limited_with clauses,
Load_Fail ("had semantic errors", U_Id, Id); -- 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;
end if; end if;
...@@ -891,7 +911,8 @@ package body Rtsfind is ...@@ -891,7 +911,8 @@ package body Rtsfind is
----------------------- -----------------------
function Find_Local_Entity (E : RE_Id) return Entity_Id 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; Ent : Entity_Id;
Save_Nam : constant String := Name_Buffer (1 .. Name_Len); Save_Nam : constant String := Name_Buffer (1 .. Name_Len);
...@@ -902,7 +923,8 @@ package body Rtsfind is ...@@ -902,7 +923,8 @@ package body Rtsfind is
Name_Buffer (1 .. Name_Len) := Name_Buffer (1 .. Name_Len) :=
RE_Str (RE_Str'First + 3 .. RE_Str'Last); 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_Len := Save_Nam'Length;
Name_Buffer (1 .. Name_Len) := Save_Nam; Name_Buffer (1 .. Name_Len) := Save_Nam;
...@@ -956,9 +978,16 @@ package body Rtsfind is ...@@ -956,9 +978,16 @@ package body Rtsfind is
pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration); pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration);
Ename := RE_Chars (E); 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 while Present (Pkg_Ent) loop
if Ename = Chars (Pkg_Ent) then if Ename = Chars (Pkg_Ent) then
RE_Table (E) := Pkg_Ent; RE_Table (E) := Pkg_Ent;
...@@ -1067,6 +1096,7 @@ package body Rtsfind is ...@@ -1067,6 +1096,7 @@ package body Rtsfind is
U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
E1 : Entity_Id; E1 : Entity_Id;
Ename : Name_Id; Ename : Name_Id;
Found_E : Entity_Id;
Lib_Unit : Node_Id; Lib_Unit : Node_Id;
Pkg_Ent : Entity_Id; Pkg_Ent : Entity_Id;
...@@ -1103,13 +1133,15 @@ package body Rtsfind is ...@@ -1103,13 +1133,15 @@ package body Rtsfind is
-- Search the entity in the components of record type declarations -- Search the entity in the components of record type declarations
-- found in the package entity chain. -- found in the package entity chain.
Found_E := Empty;
Pkg_Ent := First_Entity (U.Entity); Pkg_Ent := First_Entity (U.Entity);
Search : while Present (Pkg_Ent) loop Search : while Present (Pkg_Ent) loop
if Is_Record_Type (Pkg_Ent) then if Is_Record_Type (Pkg_Ent) then
E1 := First_Entity (Pkg_Ent); E1 := First_Entity (Pkg_Ent);
while Present (E1) loop while Present (E1) loop
if Ename = Chars (E1) then if Ename = Chars (E1) then
exit Search; pragma Assert (not Present (Found_E));
Found_E := E1;
end if; end if;
Next_Entity (E1); Next_Entity (E1);
...@@ -1157,7 +1189,7 @@ package body Rtsfind is ...@@ -1157,7 +1189,7 @@ package body Rtsfind is
end if; end if;
Front_End_Inlining := Save_Front_End_Inlining; Front_End_Inlining := Save_Front_End_Inlining;
return Check_CRT (E, E1); return Check_CRT (E, Found_E);
end RTE_Record_Component; end RTE_Record_Component;
------------------------------------ ------------------------------------
...@@ -1366,6 +1398,12 @@ package body Rtsfind is ...@@ -1366,6 +1398,12 @@ package body Rtsfind is
end if; end if;
end loop; end loop;
end if; 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 Text_IO_Kludge;
end Rtsfind; end Rtsfind;
gcc/ada/rtsfind.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -184,6 +184,7 @@ package Rtsfind is ...@@ -184,6 +184,7 @@ package Rtsfind is
-- Children of System -- Children of System
System_Address_Image,
System_Arith_64, System_Arith_64,
System_AST_Handling, System_AST_Handling,
System_Assertions, System_Assertions,
...@@ -201,6 +202,7 @@ package Rtsfind is ...@@ -201,6 +202,7 @@ package Rtsfind is
System_Compare_Array_Unsigned_8, System_Compare_Array_Unsigned_8,
System_DSA_Services, System_DSA_Services,
System_Exception_Table, System_Exception_Table,
System_Exceptions,
System_Exn_Int, System_Exn_Int,
System_Exn_LLF, System_Exn_LLF,
System_Exn_LLI, System_Exn_LLI,
...@@ -399,7 +401,7 @@ package Rtsfind is ...@@ -399,7 +401,7 @@ package Rtsfind is
-- Range of values for children of Interfaces -- Range of values for children of Interfaces
subtype System_Child is RTU_Id 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 -- Range of values for children or grandchildren of System
subtype System_Tasking_Child is System_Child subtype System_Tasking_Child is System_Child
...@@ -456,11 +458,11 @@ package Rtsfind is ...@@ -456,11 +458,11 @@ package Rtsfind is
RE_Exception_Message, -- Ada.Exceptions RE_Exception_Message, -- Ada.Exceptions
RE_Exception_Name_Simple, -- Ada.Exceptions RE_Exception_Name_Simple, -- Ada.Exceptions
RE_Exception_Occurrence, -- Ada.Exceptions RE_Exception_Occurrence, -- Ada.Exceptions
RE_Local_Raise, -- Ada.Exceptions
RE_Null_Occurrence, -- Ada.Exceptions RE_Null_Occurrence, -- Ada.Exceptions
RE_Poll, -- Ada.Exceptions RE_Poll, -- Ada.Exceptions
RE_Raise_Exception, -- Ada.Exceptions RE_Raise_Exception, -- Ada.Exceptions
RE_Raise_Exception_Always, -- Ada.Exceptions RE_Raise_Exception_Always, -- Ada.Exceptions
RE_Raise_From_Controlled_Operation, -- Ada.Exceptions
RE_Reraise_Occurrence, -- Ada.Exceptions RE_Reraise_Occurrence, -- Ada.Exceptions
RE_Reraise_Occurrence_Always, -- Ada.Exceptions RE_Reraise_Occurrence_Always, -- Ada.Exceptions
RE_Reraise_Occurrence_No_Defer, -- Ada.Exceptions RE_Reraise_Occurrence_No_Defer, -- Ada.Exceptions
...@@ -485,42 +487,45 @@ package Rtsfind is ...@@ -485,42 +487,45 @@ package Rtsfind is
RE_Stream_Access, -- Ada.Streams.Stream_IO RE_Stream_Access, -- Ada.Streams.Stream_IO
RE_Abstract_Interface, -- Ada.Tags
RE_Access_Level, -- Ada.Tags RE_Access_Level, -- Ada.Tags
RE_Address_Array, -- Ada.Tags
RE_Addr_Ptr, -- Ada.Tags RE_Addr_Ptr, -- Ada.Tags
RE_Base_Address, -- Ada.Tags RE_Base_Address, -- Ada.Tags
RE_Cstring_Ptr, -- Ada.Tags RE_Cstring_Ptr, -- Ada.Tags
RE_Default_Prim_Op_Count, -- Ada.Tags RE_Default_Prim_Op_Count, -- Ada.Tags
RE_Descendant_Tag, -- Ada.Tags RE_Descendant_Tag, -- Ada.Tags
RE_Dispatch_Table, -- Ada.Tags RE_Dispatch_Table, -- Ada.Tags
RE_Dispatch_Table_Wrapper, -- Ada.Tags
RE_Displace, -- Ada.Tags RE_Displace, -- Ada.Tags
RE_DT_Entry_Size, -- Ada.Tags RE_DT, -- Ada.Tags
RE_DT_Min_Prologue_Size, -- Ada.Tags RE_DT_Predef_Prims_Offset, -- Ada.Tags
RE_DT_Prologue_Size, -- Ada.Tags
RE_DT_Typeinfo_Ptr_Size, -- Ada.Tags RE_DT_Typeinfo_Ptr_Size, -- Ada.Tags
RE_Expanded_Name, -- Ada.Tags RE_Expanded_Name, -- Ada.Tags
RE_External_Tag, -- Ada.Tags RE_External_Tag, -- Ada.Tags
RE_HT_Link, -- Ada.Tags
RO_TA_External_Tag, -- Ada.Tags RO_TA_External_Tag, -- Ada.Tags
RE_Get_Access_Level, -- Ada.Tags RE_Get_Access_Level, -- Ada.Tags
RE_Get_Entry_Index, -- Ada.Tags RE_Get_Entry_Index, -- Ada.Tags
RE_Get_Offset_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_Prim_Op_Kind, -- Ada.Tags
RE_Get_RC_Offset, -- Ada.Tags
RE_Get_Remotely_Callable, -- Ada.Tags
RE_Get_Tagged_Kind, -- Ada.Tags RE_Get_Tagged_Kind, -- Ada.Tags
RE_Idepth, -- Ada.Tags RE_Idepth, -- Ada.Tags
RE_Iface_Tag, -- Ada.Tags
RE_Ifaces_Table, -- 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, -- Ada.Tags
RE_Interface_Data_Ptr, -- Ada.Tags
RE_Interface_Tag, -- Ada.Tags RE_Interface_Tag, -- Ada.Tags
RE_IW_Membership, -- Ada.Tags RE_IW_Membership, -- Ada.Tags
RE_Nb_Ifaces, -- 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_Object_Specific_Data, -- Ada.Tags
RE_Offset_To_Top, -- 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_Function, -- Ada.Tags
RE_POK_Procedure, -- Ada.Tags RE_POK_Procedure, -- Ada.Tags
RE_POK_Protected_Entry, -- Ada.Tags RE_POK_Protected_Entry, -- Ada.Tags
...@@ -529,34 +534,29 @@ package Rtsfind is ...@@ -529,34 +534,29 @@ package Rtsfind is
RE_POK_Task_Entry, -- Ada.Tags RE_POK_Task_Entry, -- Ada.Tags
RE_POK_Task_Function, -- Ada.Tags RE_POK_Task_Function, -- Ada.Tags
RE_POK_Task_Procedure, -- 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_Prim_Op_Kind, -- Ada.Tags
RE_Primary_DT, -- Ada.Tags
RE_Prims_Ptr, -- 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_Register_Tag, -- Ada.Tags
RE_Remotely_Callable, -- Ada.Tags RE_Transportable, -- Ada.Tags
RE_RC_Offset, -- Ada.Tags RE_RC_Offset, -- Ada.Tags
RE_Secondary_DT, -- Ada.Tags RE_Secondary_DT, -- Ada.Tags
RE_Select_Specific_Data, -- Ada.Tags RE_Select_Specific_Data, -- Ada.Tags
RE_Set_Access_Level, -- Ada.Tags
RE_Set_Entry_Index, -- 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_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_Prim_Op_Kind, -- Ada.Tags
RE_Set_RC_Offset, -- Ada.Tags RE_Static_Offset_To_Top, -- 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_Tag, -- Ada.Tags RE_Tag, -- Ada.Tags
RE_Tag_Error, -- Ada.Tags RE_Tag_Error, -- Ada.Tags
RE_Tag_Kind, -- Ada.Tags
RE_Tag_Ptr, -- Ada.Tags RE_Tag_Ptr, -- Ada.Tags
RE_Tag_Table, -- Ada.Tags
RE_Tags_Table, -- Ada.Tags RE_Tags_Table, -- Ada.Tags
RE_Tagged_Kind, -- Ada.Tags RE_Tagged_Kind, -- Ada.Tags
RE_Type_Specific_Data_Ptr, -- Ada.Tags RE_Type_Specific_Data_Ptr, -- Ada.Tags
...@@ -599,6 +599,8 @@ package Rtsfind is ...@@ -599,6 +599,8 @@ package Rtsfind is
RE_Null_Address, -- System RE_Null_Address, -- System
RE_Priority, -- System RE_Priority, -- System
RE_Address_Image, -- System.Address_Image
RE_Add_With_Ovflo_Check, -- System.Arith_64 RE_Add_With_Ovflo_Check, -- System.Arith_64
RE_Double_Divide, -- System.Arith_64 RE_Double_Divide, -- System.Arith_64
RE_Multiply_With_Ovflo_Check, -- System.Arith_64 RE_Multiply_With_Ovflo_Check, -- System.Arith_64
...@@ -607,6 +609,7 @@ package Rtsfind is ...@@ -607,6 +609,7 @@ package Rtsfind is
RE_Create_AST_Handler, -- System.AST_Handling RE_Create_AST_Handler, -- System.AST_Handling
RE_Assert_Failure, -- System.Assertions
RE_Raise_Assert_Failure, -- System.Assertions RE_Raise_Assert_Failure, -- System.Assertions
RE_AST_Handler, -- System.Aux_DEC RE_AST_Handler, -- System.Aux_DEC
...@@ -663,6 +666,8 @@ package Rtsfind is ...@@ -663,6 +666,8 @@ package Rtsfind is
RE_Register_Exception, -- System.Exception_Table RE_Register_Exception, -- System.Exception_Table
RE_Local_Raise, -- System.Exceptions
RE_Exn_Integer, -- System.Exn_Int RE_Exn_Integer, -- System.Exn_Int
RE_Exn_Long_Long_Float, -- System.Exn_LLF RE_Exn_Long_Long_Float, -- System.Exn_LLF
...@@ -1231,6 +1236,7 @@ package Rtsfind is ...@@ -1231,6 +1236,7 @@ package Rtsfind is
RE_Storage_Offset, -- System.Storage_Elements RE_Storage_Offset, -- System.Storage_Elements
RE_Storage_Array, -- System.Storage_Elements RE_Storage_Array, -- System.Storage_Elements
RE_To_Address, -- System.Storage_Elements RE_To_Address, -- System.Storage_Elements
RE_Dummy_Communication_Block, -- System.Storage_Elements
RE_Root_Storage_Pool, -- System.Storage_Pools RE_Root_Storage_Pool, -- System.Storage_Pools
RE_Allocate_Any, -- System_Storage_Pools, RE_Allocate_Any, -- System_Storage_Pools,
...@@ -1333,11 +1339,6 @@ package Rtsfind is ...@@ -1333,11 +1339,6 @@ package Rtsfind is
RE_Get_GNAT_Exception, -- System.Soft_Links RE_Get_GNAT_Exception, -- System.Soft_Links
RE_Update_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_1, -- System.Unsigned_Types
RE_Bits_2, -- System.Unsigned_Types RE_Bits_2, -- System.Unsigned_Types
RE_Bits_4, -- System.Unsigned_Types RE_Bits_4, -- System.Unsigned_Types
...@@ -1563,11 +1564,11 @@ package Rtsfind is ...@@ -1563,11 +1564,11 @@ package Rtsfind is
RE_Exception_Message => Ada_Exceptions, RE_Exception_Message => Ada_Exceptions,
RE_Exception_Name_Simple => Ada_Exceptions, RE_Exception_Name_Simple => Ada_Exceptions,
RE_Exception_Occurrence => Ada_Exceptions, RE_Exception_Occurrence => Ada_Exceptions,
RE_Local_Raise => Ada_Exceptions,
RE_Null_Occurrence => Ada_Exceptions, RE_Null_Occurrence => Ada_Exceptions,
RE_Poll => Ada_Exceptions, RE_Poll => Ada_Exceptions,
RE_Raise_Exception => Ada_Exceptions, RE_Raise_Exception => Ada_Exceptions,
RE_Raise_Exception_Always => Ada_Exceptions, RE_Raise_Exception_Always => Ada_Exceptions,
RE_Raise_From_Controlled_Operation => Ada_Exceptions,
RE_Reraise_Occurrence => Ada_Exceptions, RE_Reraise_Occurrence => Ada_Exceptions,
RE_Reraise_Occurrence_Always => Ada_Exceptions, RE_Reraise_Occurrence_Always => Ada_Exceptions,
RE_Reraise_Occurrence_No_Defer => Ada_Exceptions, RE_Reraise_Occurrence_No_Defer => Ada_Exceptions,
...@@ -1592,42 +1593,45 @@ package Rtsfind is ...@@ -1592,42 +1593,45 @@ package Rtsfind is
RE_Stream_Access => Ada_Streams_Stream_IO, RE_Stream_Access => Ada_Streams_Stream_IO,
RE_Abstract_Interface => Ada_Tags,
RE_Access_Level => Ada_Tags, RE_Access_Level => Ada_Tags,
RE_Address_Array => Ada_Tags,
RE_Addr_Ptr => Ada_Tags, RE_Addr_Ptr => Ada_Tags,
RE_Base_Address => Ada_Tags, RE_Base_Address => Ada_Tags,
RE_Cstring_Ptr => Ada_Tags, RE_Cstring_Ptr => Ada_Tags,
RE_Default_Prim_Op_Count => Ada_Tags, RE_Default_Prim_Op_Count => Ada_Tags,
RE_Descendant_Tag => Ada_Tags, RE_Descendant_Tag => Ada_Tags,
RE_Dispatch_Table => Ada_Tags, RE_Dispatch_Table => Ada_Tags,
RE_Dispatch_Table_Wrapper => Ada_Tags,
RE_Displace => Ada_Tags, RE_Displace => Ada_Tags,
RE_DT_Entry_Size => Ada_Tags, RE_DT => Ada_Tags,
RE_DT_Min_Prologue_Size => Ada_Tags, RE_DT_Predef_Prims_Offset => Ada_Tags,
RE_DT_Prologue_Size => Ada_Tags,
RE_DT_Typeinfo_Ptr_Size => Ada_Tags, RE_DT_Typeinfo_Ptr_Size => Ada_Tags,
RE_Expanded_Name => Ada_Tags, RE_Expanded_Name => Ada_Tags,
RE_External_Tag => Ada_Tags, RE_External_Tag => Ada_Tags,
RE_HT_Link => Ada_Tags,
RO_TA_External_Tag => Ada_Tags, RO_TA_External_Tag => Ada_Tags,
RE_Get_Access_Level => Ada_Tags, RE_Get_Access_Level => Ada_Tags,
RE_Get_Entry_Index => Ada_Tags, RE_Get_Entry_Index => Ada_Tags,
RE_Get_Offset_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_Prim_Op_Kind => Ada_Tags,
RE_Get_RC_Offset => Ada_Tags,
RE_Get_Remotely_Callable => Ada_Tags,
RE_Get_Tagged_Kind => Ada_Tags, RE_Get_Tagged_Kind => Ada_Tags,
RE_Idepth => Ada_Tags, RE_Idepth => Ada_Tags,
RE_Iface_Tag => Ada_Tags,
RE_Ifaces_Table => 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 => Ada_Tags,
RE_Interface_Data_Ptr => Ada_Tags,
RE_Interface_Tag => Ada_Tags, RE_Interface_Tag => Ada_Tags,
RE_IW_Membership => Ada_Tags, RE_IW_Membership => Ada_Tags,
RE_Nb_Ifaces => 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_Object_Specific_Data => Ada_Tags,
RE_Offset_To_Top => 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_Function => Ada_Tags,
RE_POK_Procedure => Ada_Tags, RE_POK_Procedure => Ada_Tags,
RE_POK_Protected_Entry => Ada_Tags, RE_POK_Protected_Entry => Ada_Tags,
...@@ -1636,34 +1640,29 @@ package Rtsfind is ...@@ -1636,34 +1640,29 @@ package Rtsfind is
RE_POK_Task_Entry => Ada_Tags, RE_POK_Task_Entry => Ada_Tags,
RE_POK_Task_Function => Ada_Tags, RE_POK_Task_Function => Ada_Tags,
RE_POK_Task_Procedure => 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_Prim_Op_Kind => Ada_Tags,
RE_Primary_DT => Ada_Tags,
RE_Prims_Ptr => 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_Register_Tag => Ada_Tags,
RE_Remotely_Callable => Ada_Tags, RE_Transportable => Ada_Tags,
RE_RC_Offset => Ada_Tags, RE_RC_Offset => Ada_Tags,
RE_Secondary_DT => Ada_Tags, RE_Secondary_DT => Ada_Tags,
RE_Select_Specific_Data => Ada_Tags, RE_Select_Specific_Data => Ada_Tags,
RE_Set_Access_Level => Ada_Tags,
RE_Set_Entry_Index => 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_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_Prim_Op_Kind => Ada_Tags,
RE_Set_RC_Offset => Ada_Tags, RE_Static_Offset_To_Top => 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_Tag => Ada_Tags, RE_Tag => Ada_Tags,
RE_Tag_Error => Ada_Tags, RE_Tag_Error => Ada_Tags,
RE_Tag_Kind => Ada_Tags,
RE_Tag_Ptr => Ada_Tags, RE_Tag_Ptr => Ada_Tags,
RE_Tag_Table => Ada_Tags,
RE_Tags_Table => Ada_Tags, RE_Tags_Table => Ada_Tags,
RE_Tagged_Kind => Ada_Tags, RE_Tagged_Kind => Ada_Tags,
RE_Type_Specific_Data_Ptr => Ada_Tags, RE_Type_Specific_Data_Ptr => Ada_Tags,
...@@ -1704,6 +1703,8 @@ package Rtsfind is ...@@ -1704,6 +1703,8 @@ package Rtsfind is
RE_Null_Address => System, RE_Null_Address => System,
RE_Priority => System, RE_Priority => System,
RE_Address_Image => System_Address_Image,
RE_Add_With_Ovflo_Check => System_Arith_64, RE_Add_With_Ovflo_Check => System_Arith_64,
RE_Double_Divide => System_Arith_64, RE_Double_Divide => System_Arith_64,
RE_Multiply_With_Ovflo_Check => System_Arith_64, RE_Multiply_With_Ovflo_Check => System_Arith_64,
...@@ -1712,6 +1713,7 @@ package Rtsfind is ...@@ -1712,6 +1713,7 @@ package Rtsfind is
RE_Create_AST_Handler => System_AST_Handling, RE_Create_AST_Handler => System_AST_Handling,
RE_Assert_Failure => System_Assertions,
RE_Raise_Assert_Failure => System_Assertions, RE_Raise_Assert_Failure => System_Assertions,
RE_AST_Handler => System_Aux_DEC, RE_AST_Handler => System_Aux_DEC,
...@@ -1768,6 +1770,8 @@ package Rtsfind is ...@@ -1768,6 +1770,8 @@ package Rtsfind is
RE_Register_Exception => System_Exception_Table, RE_Register_Exception => System_Exception_Table,
RE_Local_Raise => System_Exceptions,
RE_Exn_Integer => System_Exn_Int, RE_Exn_Integer => System_Exn_Int,
RE_Exn_Long_Long_Float => System_Exn_LLF, RE_Exn_Long_Long_Float => System_Exn_LLF,
...@@ -2336,6 +2340,7 @@ package Rtsfind is ...@@ -2336,6 +2340,7 @@ package Rtsfind is
RE_Storage_Offset => System_Storage_Elements, RE_Storage_Offset => System_Storage_Elements,
RE_Storage_Array => System_Storage_Elements, RE_Storage_Array => System_Storage_Elements,
RE_To_Address => System_Storage_Elements, RE_To_Address => System_Storage_Elements,
RE_Dummy_Communication_Block => System_Storage_Elements,
RE_Root_Storage_Pool => System_Storage_Pools, RE_Root_Storage_Pool => System_Storage_Pools,
RE_Allocate_Any => System_Storage_Pools, RE_Allocate_Any => System_Storage_Pools,
...@@ -2438,11 +2443,6 @@ package Rtsfind is ...@@ -2438,11 +2443,6 @@ package Rtsfind is
RE_Get_GNAT_Exception => System_Soft_Links, RE_Get_GNAT_Exception => System_Soft_Links,
RE_Update_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_1 => System_Unsigned_Types,
RE_Bits_2 => System_Unsigned_Types, RE_Bits_2 => System_Unsigned_Types,
RE_Bits_4 => System_Unsigned_Types, RE_Bits_4 => System_Unsigned_Types,
...@@ -2808,9 +2808,9 @@ package Rtsfind is ...@@ -2808,9 +2808,9 @@ package Rtsfind is
-- construct. -- construct.
function RTE_Available (E : RE_Id) return Boolean; function RTE_Available (E : RE_Id) return Boolean;
-- Returns true if a call to RTE will succeed without raising an -- Returns true if a call to RTE will succeed without raising an exception
-- exception and without generating an error message, i.e. if the -- and without generating an error message, i.e. if the call will obtain
-- call will obtain the desired entity without any problems. -- the desired entity without any problems.
function RTE_Record_Component (E : RE_Id) return Entity_Id; function RTE_Record_Component (E : RE_Id) return Entity_Id;
-- Given the entity defined in the above tables, as identified by the -- Given the entity defined in the above tables, as identified by the
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment