Skip to content

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

a-tags.ads, a-tags.adb (Offset_To_Top): Moved from the package body to the… 

a-tags.ads, a-tags.adb (Offset_To_Top): Moved from the package body to the specification because the frontend generates...

2005-12-05  Javier Miranda  <miranda@adacore.com>
	    Hristian Kirtchev  <kirtchev@adacore.com>

	* a-tags.ads, a-tags.adb (Offset_To_Top): Moved from the package body
	to the specification because the frontend generates code that uses this
	subprogram.
	(Set_Interface_Table): Add missing assertion.
	Update documentation describing the run-time structure.
	(Displace): New subprogram that displaces the pointer to the object
	to reference one of its secondary dispatch tables.
	(IW_Membership): Modified to use the new table of interfaces.
	(Inherit_TSD): Modified to use the new table of interfaces.
	(Register_Interface_Tag): Use the additional formal to fill the
	contents of the new table of interfaces.
	(Set_Interface_Table): New subprogram that stores in the TSD the
	pointer to the table of interfaces.
	(Set_Offset_To_Top): Use the additional formal to save copy of
	the offset value in the table of interfaces.
	Update structure of GNAT Primary and Secondary dispatch table diagram.
	Add comment section on GNAT dispatch table prologue.
	(Offset_To_Signature): Update the constant value of the Signature field.
	(Dispatch_Table): Update comment on hidden fields in the prologue.
	(Get_Entry_Index, Get_Prim_Op_Kind, Get_Offset_Index, OSD,
	Set_Entry_Index, Set_Offset_Index, Set_Prim_Op_Kind, SSD, TSD): Change
	the type of formal parameter T to Tag, introduce additional assertions.
	(Get_Num_Prim_Ops, Set_Num_Prim_Ops): Remove an unnecessary type
	conversion.
	(Get_Tagged_Kind, Set_Tagged_Kind): New bodies.

	* exp_ch6.adb (Register_Interface_DT_Entry): Remove the Thunk_Id actual
	in all the calls to Expand_Interface_Thunk. Instead of referencing the
	record component containing the tag of the secondary dispatch table we
	have to use the Offset_To_Top run-time function to get this information;
	otherwise if the pointer to the base of the object has been displace
	we get a wrong value if we use the 'position attribute.

	* exp_disp.adb (Expand_Interface_Thunk): Remove the Thunk_Id actual in
	all the calls to Expand_Interface_Thunk.
	(Make_Secondary_DT): Secondary dispatch tables do not have a table of
	interfaces; hence the call to Set_Interface_Table was clearly wrong.
	(Collect_All_Interfaces): Modify the internal subprogram Collect to
	ensure that the interfaces implemented by the ancestors are placed
	at the header of the generated list.
	(Expand_Interface_Conversion): Handle the case in which the displacement
	associated with the interface conversion is not statically known. In
	this case we generate a call to the new run-time subprogram Displace.
	(Make_DT): Generate and fill the new table of interfaces.
	(Ada_Actions, Action_Is_Proc, Action_Nb_Arg): Add entries for
	Get_Tagged_Kind and Set_Tagged_Kind.
	(Tagged_Kind): New function that determines the tagged kind of a type
	with respect to limitedness and concurrency and returns a reference to
	RE_Tagged_Kind.
	(Make_Disp_Asynchronous_Select_Body, Make_Disp_Conditional_Select_Body,
	Make_Disp_Timed_Select_Body): Correctly retrieve the pointer to the
	primary dispatch table for a type.
	(Make_DT, Make_Secondary_DT): Set the tagged kind in the primary and
	secondary dispatch table respectively of a tagged type.

	* exp_disp.ads (Expand_Interface_Thunk): Remove Thunk_Id formal.
	(Expand_Interface_Conversion): New subprogram to indicate if the
	displacement of the type conversion is statically known.
	(DT_Access_Action): Add values Get_Tagged_Kind and Set_Tagged_Kind.

	* rtsfind.ads (RE_Offset_To_Top): New entity
	(RTU_Id): Add Ada_Task_Termination to the list so that it is made
	accessible to users.
	(Re_Displace): New entity
	(RE_Interface_Data): New entity
	(RE_Set_Interface_Data): New_Entity
	(RE_Id, RE_Unit_Table): Add entry for RE_Get_Tagged_Kind,
	Set_Tagged_Kind, RE_Tagged_Kind, RE_TK_Abstract_Limited_Tagged,
	RE_TK_Abstract_Tagged, RE_TK_Limited_Tagged, RE_TK_Protected,
	RE_TK_Tagged, RE_TK_Task.

	* exp_ch3.adb (Init_Secondary_Tags): Modify the subprogram
	Init_Secondary_Tags_Internal to allow its use with interface types and
	also to generate the code for the new additional actual required
	by Set_Offset_To_Top.
	(Build_Init_Statements): In case of components associated with abstract
	interface types there is no need to generate a call to its IP.
	(Freeze_Record_Type): Generate Select Specific Data tables only for
	concurrent types.
	(Make_Predefined_Primitive_Specs, Predefined_Primitive_Bodies): Generate
	the bodies and specifications of the predefined primitive operations
	dealing with dispatching selects and abort, 'Callable, 'Terminated only
	for concurrent types.

        * exp_sel.ads, exp_sel.adb: New files.

	* exp_ch9.adb (Build_Protected_Entry, Expand_N_Protected_Body,
	Expand_N_Protected_Type_Declaration, Make_Initialize_Protection): Handle
	properly protected objects and attach handler in the case of the
	restricted profile.
	Move embeded package Select_Expansion_Utilities into a separate external
	package.
	(Expand_N_Asynchronous_Select, Expand_N_Conditional_Select,
	Expand_N_Timed_Entry_Call): Correct calls external package Exp_Sel.
	(Build_K, Build_S_Assignment): New subprograms, part of the select
	expansion utilities.
	(Expand_N_Asynchronous_Select, Expand_N_Conditional_Entry_Call,
	Expand_N_Timed_Entry_Call): Optimize expansion of select statements
	where the trigger is a dispatching procedure of a limited tagged type.

From-SVN: r108284
parent e51b97be
Showing with 1750 additions and 947 deletions
gcc/ada/a-tags.adb
......@@ -41,47 +41,53 @@ package body Ada.Tags is
-- Structure of the GNAT Primary Dispatch Table
-- +-----------------------+
-- | Signature |
-- +-----------------------+
-- | Offset_To_Top |
-- +-----------------------+
-- | Typeinfo_Ptr/TSD_Ptr | ---> Type Specific Data
-- Tag ---> +-----------------------+ +-------------------+
-- | table of | | inheritance depth |
-- : primitive ops : +-------------------+
-- | pointers | | access level |
-- +-----------------------+ +-------------------+
-- | expanded name |
-- +-------------------+
-- | external tag |
-- +-------------------+
-- | hash table link |
-- +-------------------+
-- | remotely callable |
-- +-------------------+
-- | rec ctrler offset |
-- +-------------------+
-- | num prim ops |
-- +-------------------+
-- | num interfaces |
-- +-------------------+
-- Select Specific Data <--- | SSD_Ptr |
-- +-----------------------+ +-------------------+
-- | table of primitive | | table of |
-- : operation : : ancestor :
-- | kinds | | tags |
-- +-----------------------+ +-------------------+
-- | table of | | table of |
-- : entry : : interface :
-- | indices | | tags |
-- +-----------------------+ +-------------------+
-- +----------------------+
-- | Signature |
-- +----------------------+
-- | Tagged_Kind |
-- +----------------------+
-- | Offset_To_Top |
-- +----------------------+
-- | Typeinfo_Ptr/TSD_Ptr ---> Type Specific Data
-- Tag ---> +----------------------+ +-------------------+
-- | table of | | inheritance depth |
-- : primitive ops : +-------------------+
-- | pointers | | access level |
-- +----------------------+ +-------------------+
-- | expanded name |
-- +-------------------+
-- | external tag |
-- +-------------------+
-- | hash table link |
-- +-------------------+
-- | remotely callable |
-- +-------------------+
-- | rec ctrler offset |
-- +-------------------+
-- | num prim ops |
-- +-------------------+
-- | num interfaces |
-- +-------------------+
-- | Ifaces_Table_Ptr --> Interface Data
-- +-------------------+ +------------+
-- Select Specific Data <---- SSD_Ptr | | table |
-- +--------------------+ +-------------------+ : of :
-- | table of primitive | | table of | | interfaces |
-- : operation : : ancestor : +------------+
-- | kinds | | tags |
-- +--------------------+ +-------------------+
-- | table of |
-- : entry :
-- | indices |
-- +--------------------+
-- Structure of the GNAT Secondary Dispatch Table
-- +-----------------------+
-- | Signature |
-- +-----------------------+
-- | Tagged_Kind |
-- +-----------------------+
-- | Offset_To_Top |
-- +-----------------------+
-- | OSD_Ptr |---> Object Specific Data
......@@ -93,10 +99,77 @@ package body Ada.Tags is
-- | op offsets |
-- +---------------+
Offset_To_Signature : constant SSE.Storage_Count :=
DT_Typeinfo_Ptr_Size
+ DT_Offset_To_Top_Size
+ DT_Signature_Size;
----------------------------------
-- GNAT Dispatch Table Prologue --
----------------------------------
-- GNAT's Dispatch Table prologue contains several fields which are hidden
-- in order to preserve compatibility with C++. These fields are accessed
-- by address calculations performed in the following manner:
-- Field : Field_Type :=
-- (To_Address (Tag) - Sum_Of_Preceding_Field_Sizes).all;
-- The bracketed subtraction shifts the pointer (Tag) from the table of
-- primitive operations (or thunks) to the field in question. Since the
-- result of the subtraction is an address, dereferencing it will obtain
-- the actual value of the field.
-- Guidelines for addition of new hidden fields
-- Define a Field_Type and Field_Type_Ptr (access to Field_Type) in
-- A-Tags.ads for the newly introduced field.
-- Defined the size of the new field as a constant Field_Name_Size
-- Introduce an Unchecked_Conversion from System.Address to
-- Field_Type_Ptr in A-Tags.ads.
-- Define the specifications of Get_<Field_Name> and Set_<Field_Name>
-- in A-Tags.ads.
-- Update the GNAT Dispatch Table structure in A-Tags.adb
-- Provide bodies to the Get_<Field_Name> and Set_<Field_Name> routines.
-- The profile of a Get_<Field_Name> routine should resemble:
-- function Get_<Field_Name> (T : Tag; ...) return Field_Type is
-- Field : constant System.Address :=
-- To_Address (T) - <Sum_Of_Previous_Field_Sizes>;
-- begin
-- pragma Assert (Check_Signature (T, <Applicable_DT>));
-- <Additional_Assertions>
-- return To_Field_Type_Ptr (Field).all;
-- end Get_<Field_Name>;
-- The profile of a Set_<Field_Name> routine should resemble:
-- procedure Set_<Field_Name> (T : Tag; ..., Value : Field_Type) is
-- Field : constant System.Address :=
-- To_Address (T) - <Sum_Of_Previous_Field_Sizes>;
-- begin
-- pragma Assert (Check_Signature (T, <Applicable_DT>));
-- <Additional_Assertions>
-- To_Field_Type_Ptr (Field).all := Value;
-- end Set_<Field_Name>;
-- NOTE: For each field in the prologue which precedes the newly added
-- one, find and update its respective Sum_Of_Previous_Field_Sizes by
-- subtractind Field_Name_Size from it. Falure to do so will clobber the
-- previous prologue field.
K_Typeinfo : constant SSE.Storage_Count := DT_Typeinfo_Ptr_Size;
K_Offset_To_Top : constant SSE.Storage_Count :=
K_Typeinfo + DT_Offset_To_Top_Size;
K_Tagged_Kind : constant SSE.Storage_Count :=
K_Offset_To_Top + DT_Tagged_Kind_Size;
K_Signature : constant SSE.Storage_Count :=
K_Tagged_Kind + DT_Signature_Size;
subtype Cstring is String (Positive);
type Cstring_Ptr is access all Cstring;
......@@ -108,6 +181,20 @@ package body Ada.Tags is
pragma Suppress_Initialization (Tag_Table);
pragma Suppress (Index_Check, On => Tag_Table);
-- Declarations for the table of interfaces
type Interface_Data_Element is record
Iface_Tag : Tag;
Offset : System.Storage_Elements.Storage_Offset;
end record;
type Interfaces_Array is
array (Natural range <>) of Interface_Data_Element;
type Interface_Data (Nb_Ifaces : Positive) is record
Table : Interfaces_Array (1 .. Nb_Ifaces);
end record;
-- Object specific data types
type Object_Specific_Data_Array is array (Positive range <>) of Positive;
......@@ -171,17 +258,16 @@ package body Ada.Tags is
-- Controller Offset: Used to give support to tagged controlled objects
-- (see Get_Deep_Controller at s-finimp)
Ifaces_Table_Ptr : System.Address;
-- Pointer to the table of interface tags. It is used to implement the
-- membership test associated with interfaces and also for backward
-- abstract interface type conversions (Ada 2005:AI-251)
Num_Prim_Ops : Natural;
-- Number of primitive operations of the dispatch table. This field is
-- used for additional run-time checks when the run-time is compiled
-- with assertions enabled.
Num_Interfaces : Natural;
-- Number of abstract interface types implemented by the tagged type.
-- The value Idepth+Num_Interfaces indicates the end of the second table
-- stored in the Tags_Table component. It is used to implement the
-- membership test associated with interfaces (Ada 2005:AI-251).
SSD_Ptr : System.Address;
-- Pointer to a table of records used in dispatching selects. This
-- field has a meaningful value for all tagged types that implement
......@@ -210,6 +296,8 @@ package body Ada.Tags is
-- 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;
......@@ -305,11 +393,6 @@ package body Ada.Tags is
-- Length of string represented by the given pointer (treating the string
-- as a C-style string, which is Nul terminated).
function Offset_To_Top
(T : Tag) return System.Storage_Elements.Storage_Offset;
-- Returns the current value of the offset_to_top component available in
-- the prologue of the dispatch table.
function Typeinfo_Ptr (T : Tag) return System.Address;
-- Returns the current value of the typeinfo_ptr component available in
-- the prologue of the dispatch table.
......@@ -425,21 +508,20 @@ package body Ada.Tags is
---------------------
function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean is
Offset_To_Top_Ptr : constant Storage_Offset_Ptr :=
To_Storage_Offset_Ptr (To_Address (T)
- Offset_To_Signature);
Signature : constant Storage_Offset_Ptr :=
To_Storage_Offset_Ptr (To_Address (T) - K_Signature);
Signature : constant Signature_Values :=
To_Signature_Values (Offset_To_Top_Ptr.all);
Sig_Values : constant Signature_Values :=
To_Signature_Values (Signature.all);
Signature_Id : Signature_Kind;
begin
if Signature (1) /= Valid_Signature then
if Sig_Values (1) /= Valid_Signature then
Signature_Id := Unknown;
elsif Signature (2) in Primary_DT .. Abstract_Interface then
Signature_Id := Signature (2);
elsif Sig_Values (2) in Primary_DT .. Abstract_Interface then
Signature_Id := Sig_Values (2);
else
Signature_Id := Unknown;
......@@ -522,6 +604,54 @@ package body Ada.Tags is
return Pos >= 0 and then TSD (Obj_Tag).Tags_Table (Pos) = Typ_Tag;
end CW_Membership;
--------------
-- Displace --
--------------
function Displace
(This : System.Address;
T : Tag) return System.Address
is
Curr_DT : constant Tag := To_Tag_Ptr (This).all;
Iface_Table : Interface_Data_Ptr;
Obj_Base : System.Address;
Obj_DT : Tag;
Obj_TSD : Type_Specific_Data_Ptr;
begin
pragma Assert
(Check_Signature (Curr_DT, Must_Be_Primary_Or_Secondary_DT));
pragma Assert
(Check_Signature (T, Must_Be_Interface));
Obj_Base := This - Offset_To_Top (Curr_DT);
Obj_DT := To_Tag_Ptr (Obj_Base).all;
pragma Assert
(Check_Signature (Obj_DT, Must_Be_Primary_DT));
Obj_TSD := TSD (Obj_DT);
Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop
if Iface_Table.Table (Id).Iface_Tag = T then
Obj_Base := Obj_Base + Iface_Table.Table (Id).Offset;
Obj_DT := To_Tag_Ptr (Obj_Base).all;
pragma Assert
(Check_Signature (Obj_DT, Must_Be_Secondary_DT));
return Obj_Base;
end if;
end loop;
end if;
-- If the object does not implement the interface we must raise CE
raise Constraint_Error;
end Displace;
-------------------
-- IW_Membership --
-------------------
......@@ -537,12 +667,12 @@ package body Ada.Tags is
-- that are contained in the dispatch table referenced by Obj'Tag.
function IW_Membership (This : System.Address; T : Tag) return Boolean is
Curr_DT : constant Tag := To_Tag_Ptr (This).all;
Id : Natural;
Last_Id : Natural;
Obj_Base : System.Address;
Obj_DT : Tag;
Obj_TSD : Type_Specific_Data_Ptr;
Curr_DT : constant Tag := To_Tag_Ptr (This).all;
Iface_Table : Interface_Data_Ptr;
Last_Id : Natural;
Obj_Base : System.Address;
Obj_DT : Tag;
Obj_TSD : Type_Specific_Data_Ptr;
begin
pragma Assert
......@@ -554,29 +684,32 @@ package body Ada.Tags is
Obj_DT := To_Tag_Ptr (Obj_Base).all;
pragma Assert
(Check_Signature (Curr_DT, Must_Be_Primary_DT));
(Check_Signature (Obj_DT, Must_Be_Primary_DT));
Obj_TSD := TSD (Obj_DT);
Last_Id := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces;
if Obj_TSD.Num_Interfaces > 0 then
Last_Id := Obj_TSD.Idepth;
-- Traverse the ancestor tags table plus the interface tags table.
-- The former part is required for:
-- Look for the tag in the table of interfaces
-- Iface_CW in Typ'Class
Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
Id := 0;
loop
if Obj_TSD.Tags_Table (Id) = T then
if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop
if Iface_Table.Table (Id).Iface_Tag = T then
return True;
end if;
Id := Id + 1;
exit when Id > Last_Id;
end loop;
end if;
-- Look for the tag in the ancestor tags table. This is required for:
-- Iface_CW in Typ'Class
for Id in 0 .. Last_Id loop
if Obj_TSD.Tags_Table (Id) = T then
return True;
end if;
end loop;
return False;
end IW_Membership;
......@@ -652,6 +785,7 @@ package body Ada.Tags is
Index : constant Integer := Position - Default_Prim_Op_Count;
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
pragma Assert (Check_Index (T, Position));
pragma Assert (Index > 0);
return SSD (T).SSD_Table (Index).Index;
end Get_Entry_Index;
......@@ -677,7 +811,7 @@ package body Ada.Tags is
if Is_Primary_DT (T) then
return TSD (T).Num_Prim_Ops;
else
return OSD (Interface_Tag (T)).Num_Prim_Ops;
return OSD (T).Num_Prim_Ops;
end if;
end Get_Num_Prim_Ops;
......@@ -706,6 +840,7 @@ package body Ada.Tags is
Index : constant Integer := Position - Default_Prim_Op_Count;
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
pragma Assert (Check_Index (T, Position));
pragma Assert (Index > 0);
return SSD (T).SSD_Table (Index).Kind;
end Get_Prim_Op_Kind;
......@@ -715,12 +850,13 @@ package body Ada.Tags is
----------------------
function Get_Offset_Index
(T : Interface_Tag;
(T : Tag;
Position : Positive) return Positive
is
Index : constant Integer := Position - Default_Prim_Op_Count;
begin
pragma Assert (Check_Signature (Tag (T), Must_Be_Secondary_DT));
pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
pragma Assert (Check_Index (T, Position));
pragma Assert (Index > 0);
return OSD (T).OSD_Table (Index);
end Get_Offset_Index;
......@@ -745,6 +881,18 @@ package body Ada.Tags is
return TSD (T).Remotely_Callable;
end Get_Remotely_Callable;
---------------------
-- Get_Tagged_Kind --
---------------------
function Get_Tagged_Kind (T : Tag) return Tagged_Kind is
Tagged_Kind_Ptr : constant System.Address :=
To_Address (T) - K_Tagged_Kind;
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
return To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all;
end Get_Tagged_Kind;
----------------
-- Inherit_DT --
----------------
......@@ -766,8 +914,10 @@ package body Ada.Tags is
-----------------
procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag) is
New_TSD_Ptr : Type_Specific_Data_Ptr;
Old_TSD_Ptr : Type_Specific_Data_Ptr;
New_TSD_Ptr : Type_Specific_Data_Ptr;
New_Iface_Table_Ptr : Interface_Data_Ptr;
Old_TSD_Ptr : Type_Specific_Data_Ptr;
Old_Iface_Table_Ptr : Interface_Data_Ptr;
begin
pragma Assert (Check_Signature (New_Tag, Must_Be_Primary_Or_Interface));
......@@ -778,18 +928,29 @@ package body Ada.Tags is
(Check_Signature (Old_Tag, Must_Be_Primary_Or_Interface));
Old_TSD_Ptr := TSD (Old_Tag);
New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1;
New_TSD_Ptr.Num_Interfaces := Old_TSD_Ptr.Num_Interfaces;
-- Copy the "table of ancestor tags" plus the "table of interfaces"
-- of the parent.
New_TSD_Ptr.Tags_Table
(1 .. New_TSD_Ptr.Idepth + New_TSD_Ptr.Num_Interfaces) :=
Old_TSD_Ptr.Tags_Table
(0 .. Old_TSD_Ptr.Idepth + Old_TSD_Ptr.Num_Interfaces);
New_TSD_Ptr.Tags_Table (1 .. New_TSD_Ptr.Idepth) :=
Old_TSD_Ptr.Tags_Table (0 .. Old_TSD_Ptr.Idepth);
-- Copy the table of interfaces of the parent
if not System."=" (Old_TSD_Ptr.Ifaces_Table_Ptr,
System.Null_Address)
then
Old_Iface_Table_Ptr :=
To_Interface_Data_Ptr (Old_TSD_Ptr.Ifaces_Table_Ptr);
New_Iface_Table_Ptr :=
To_Interface_Data_Ptr (New_TSD_Ptr.Ifaces_Table_Ptr);
New_Iface_Table_Ptr.Table (1 .. Old_Iface_Table_Ptr.Nb_Ifaces) :=
Old_Iface_Table_Ptr.Table (1 .. Old_Iface_Table_Ptr.Nb_Ifaces);
end if;
else
New_TSD_Ptr.Idepth := 0;
New_TSD_Ptr.Num_Interfaces := 0;
New_TSD_Ptr.Idepth := 0;
end if;
New_TSD_Ptr.Tags_Table (0) := New_Tag;
......@@ -845,13 +1006,12 @@ package body Ada.Tags is
-------------------
function Is_Primary_DT (T : Tag) return Boolean is
Offset_To_Top_Ptr : constant Storage_Offset_Ptr :=
To_Storage_Offset_Ptr (To_Address (T)
- Offset_To_Signature);
Signature : constant Signature_Values :=
To_Signature_Values (Offset_To_Top_Ptr.all);
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 Signature (2) = Primary_DT;
return Sig_Values (2) = Primary_DT;
end Is_Primary_DT;
------------
......@@ -876,26 +1036,22 @@ package body Ada.Tags is
function Offset_To_Top
(T : Tag) return System.Storage_Elements.Storage_Offset
is
Offset_To_Top_Ptr : constant Storage_Offset_Ptr :=
To_Storage_Offset_Ptr (To_Address (T)
- DT_Typeinfo_Ptr_Size
- DT_Offset_To_Top_Size);
Offset_To_Top : constant Storage_Offset_Ptr :=
To_Storage_Offset_Ptr
(To_Address (T) - K_Offset_To_Top);
begin
return Offset_To_Top_Ptr.all;
return Offset_To_Top.all;
end Offset_To_Top;
---------
-- OSD --
---------
function OSD
(T : Interface_Tag) return Object_Specific_Data_Ptr
is
OSD_Ptr : Addr_Ptr;
function OSD (T : Tag) return Object_Specific_Data_Ptr is
OSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - K_Typeinfo);
begin
OSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
return To_Object_Specific_Data_Ptr (OSD_Ptr.all);
end OSD;
......@@ -952,39 +1108,24 @@ package body Ada.Tags is
-- Register_Interface_Tag --
----------------------------
procedure Register_Interface_Tag (T : Tag; Interface_T : Tag) is
New_T_TSD : Type_Specific_Data_Ptr;
Index : Natural;
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
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
pragma Assert (Check_Signature (Interface_T, Must_Be_Interface));
New_T_TSD := TSD (T);
-- Check if the interface is already registered
if New_T_TSD.Num_Interfaces > 0 then
declare
Id : Natural := New_T_TSD.Idepth + 1;
Last_Id : constant Natural := New_T_TSD.Idepth
+ New_T_TSD.Num_Interfaces;
New_T_TSD := TSD (T);
Iface_Table := To_Interface_Data_Ptr (New_T_TSD.Ifaces_Table_Ptr);
begin
loop
if New_T_TSD.Tags_Table (Id) = Interface_T then
return;
end if;
Id := Id + 1;
exit when Id > Last_Id;
end loop;
end;
end if;
pragma Assert (Position <= Iface_Table.Nb_Ifaces);
New_T_TSD.Num_Interfaces := New_T_TSD.Num_Interfaces + 1;
Index := New_T_TSD.Idepth + New_T_TSD.Num_Interfaces;
New_T_TSD.Tags_Table (Index) := Interface_T;
Iface_Table.Table (Position).Iface_Tag := Interface_T;
end Register_Interface_Tag;
------------------
......@@ -1016,9 +1157,9 @@ package body Ada.Tags is
Value : Positive)
is
Index : constant Integer := Position - Default_Prim_Op_Count;
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
pragma Assert (Check_Index (T, Position));
pragma Assert (Index > 0);
SSD (T).SSD_Table (Index).Index := Value;
end Set_Entry_Index;
......@@ -1044,6 +1185,16 @@ package body Ada.Tags is
TSD (T).External_Tag := To_Cstring_Ptr (Value);
end Set_External_Tag;
-------------------------
-- Set_Interface_Table --
-------------------------
procedure Set_Interface_Table (T : Tag; Value : System.Address) is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
TSD (T).Ifaces_Table_Ptr := Value;
end Set_Interface_Table;
----------------------
-- Set_Num_Prim_Ops --
----------------------
......@@ -1055,7 +1206,7 @@ package body Ada.Tags is
if Is_Primary_DT (T) then
TSD (T).Num_Prim_Ops := Value;
else
OSD (Interface_Tag (T)).Num_Prim_Ops := Value;
OSD (T).Num_Prim_Ops := Value;
end if;
end Set_Num_Prim_Ops;
......@@ -1064,13 +1215,14 @@ package body Ada.Tags is
----------------------
procedure Set_Offset_Index
(T : Interface_Tag;
(T : Tag;
Position : Positive;
Value : Positive)
is
Index : constant Integer := Position - Default_Prim_Op_Count;
begin
pragma Assert (Check_Signature (Tag (T), Must_Be_Secondary_DT));
pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
pragma Assert (Check_Index (T, Position));
pragma Assert (Index > 0);
OSD (T).OSD_Table (Index) := Value;
end Set_Offset_Index;
......@@ -1080,27 +1232,78 @@ package body Ada.Tags is
-----------------------
procedure Set_Offset_To_Top
(T : Tag;
Value : System.Storage_Elements.Storage_Offset)
(This : System.Address;
Interface_T : Tag;
Offset_Value : System.Storage_Elements.Storage_Offset)
is
Offset_To_Top_Ptr : constant Storage_Offset_Ptr :=
To_Storage_Offset_Ptr (To_Address (T)
- DT_Typeinfo_Ptr_Size
- DT_Offset_To_Top_Size);
Prim_DT : Tag;
Sec_Base : System.Address;
Sec_DT : Tag;
Offset_To_Top : Storage_Offset_Ptr;
Iface_Table : Interface_Data_Ptr;
Obj_TSD : Type_Specific_Data_Ptr;
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
Offset_To_Top_Ptr.all := Value;
if System."=" (This, System.Null_Address) then
pragma Assert
(Check_Signature (Interface_T, Must_Be_Primary_DT));
pragma Assert (Offset_Value = 0);
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;
pragma Assert
(Check_Signature (Prim_DT, Must_Be_Primary_DT));
Sec_Base := This + Offset_Value;
Sec_DT := To_Tag_Ptr (Sec_Base).all;
Offset_To_Top :=
To_Storage_Offset_Ptr (To_Address (Sec_DT) - K_Offset_To_Top);
pragma Assert
(Check_Signature (Sec_DT, Must_Be_Primary_Or_Secondary_DT));
Offset_To_Top.all := Offset_Value;
-- Save Offset_Value in the table of interfaces of the primary DT. This
-- data will be used by the subprogram "Displace" to give support to
-- backward abstract interface type conversions.
Obj_TSD := TSD (Prim_DT);
Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
-- Register the offset in the table of interfaces
if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop
if Iface_Table.Table (Id).Iface_Tag = Interface_T then
Iface_Table.Table (Id).Offset := Offset_Value;
return;
end if;
end loop;
end if;
-- If we arrive here there is some error in the run-time data structure
raise Program_Error;
end Set_Offset_To_Top;
-------------
-- Set_OSD --
-------------
procedure Set_OSD (T : Interface_Tag; Value : System.Address) is
OSD_Ptr : Addr_Ptr;
procedure Set_OSD (T : Tag; Value : System.Address) is
OSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - K_Typeinfo);
begin
pragma Assert (Check_Signature (Tag (T), Must_Be_Secondary_DT));
OSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
OSD_Ptr.all := Value;
end Set_OSD;
......@@ -1131,6 +1334,7 @@ package body Ada.Tags is
Index : constant Integer := Position - Default_Prim_Op_Count;
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
pragma Assert (Check_Index (T, Position));
pragma Assert (Index > 0);
SSD (T).SSD_Table (Index).Kind := Value;
end Set_Prim_Op_Kind;
......@@ -1165,6 +1369,18 @@ package body Ada.Tags is
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
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all := Value;
end Set_Tagged_Kind;
-------------
-- Set_TSD --
-------------
......@@ -1173,7 +1389,7 @@ package body Ada.Tags is
TSD_Ptr : Addr_Ptr;
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD_Ptr := To_Addr_Ptr (To_Address (T) - K_Typeinfo);
TSD_Ptr.all := Value;
end Set_TSD;
......@@ -1183,6 +1399,7 @@ package body Ada.Tags is
function SSD (T : Tag) return Select_Specific_Data_Ptr is
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
return To_Select_Specific_Data_Ptr (TSD (T).SSD_Ptr);
end SSD;
......@@ -1192,7 +1409,7 @@ package body Ada.Tags is
function Typeinfo_Ptr (T : Tag) return System.Address is
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
To_Addr_Ptr (To_Address (T) - K_Typeinfo);
begin
return TSD_Ptr.all;
end Typeinfo_Ptr;
......@@ -1203,8 +1420,9 @@ package body Ada.Tags is
function TSD (T : Tag) return Type_Specific_Data_Ptr is
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
To_Addr_Ptr (To_Address (T) - K_Typeinfo);
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
return To_Type_Specific_Data_Ptr (TSD_Ptr.all);
end TSD;
......
gcc/ada/a-tags.ads
......@@ -102,6 +102,11 @@ private
No_Tag : constant Tag := null;
type Interface_Data (Nb_Ifaces : Positive);
type Interface_Data_Ptr is access all Interface_Data;
-- Table of abstract interfaces used to give support to backward interface
-- conversions and also to IW_Membership.
type Object_Specific_Data (Nb_Prim : Positive);
type Object_Specific_Data_Ptr is access all Object_Specific_Data;
-- Information associated with the secondary dispatch table of tagged-type
......@@ -132,6 +137,18 @@ private
POK_Task_Function,
POK_Task_Procedure);
-- Tagged type kinds with respect to concurrency and limitedness
type Tagged_Kind is
(TK_Abstract_Limited_Tagged,
TK_Abstract_Tagged,
TK_Limited_Tagged,
TK_Protected,
TK_Tagged,
TK_Task);
type Tagged_Kind_Ptr is access all Tagged_Kind;
Default_Prim_Op_Count : constant Positive := 15;
-- Number of predefined primitive operations added by the Expander for a
-- tagged type. It is utilized for indexing in the two auxiliary tables
......@@ -160,6 +177,10 @@ private
-- return O in T'Class.
-- end Test;
function Displace (This : System.Address; T : Tag) return System.Address;
-- (Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch
-- table of T.
function Get_Access_Level (T : Tag) return Natural;
-- Given the tag associated with a type, returns the accessibility level
-- of the type.
......@@ -173,7 +194,7 @@ private
-- the external name.
function Get_Offset_Index
(T : Interface_Tag;
(T : Tag;
Position : Positive) return Positive;
-- Given a pointer to a secondary dispatch table (T) and a position of an
-- operation in the DT, retrieve the corresponding operation's position in
......@@ -204,6 +225,11 @@ private
function Get_Remotely_Callable (T : Tag) return Boolean;
-- Return the value previously set by Set_Remotely_Callable
function Get_Tagged_Kind (T : Tag) return Tagged_Kind;
-- Given a pointer to either a primary or a secondary dispatch table,
-- return the tagged kind of a type in the context of concurrency and
-- limitedness.
procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural);
-- Entry point used to initialize the DT of a type knowing the tag
-- of the direct ancestor and the number of primitive ops that are
......@@ -212,7 +238,12 @@ private
procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag);
-- Initialize the TSD of a type knowing the tag of the direct ancestor
function OSD (T : Interface_Tag) return Object_Specific_Data_Ptr;
function Offset_To_Top
(T : Tag) return System.Storage_Elements.Storage_Offset;
-- Returns the current value of the offset_to_top component available in
-- the prologue of the dispatch table.
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 Objet Specific
-- Data table.
......@@ -228,38 +259,63 @@ private
pragma Export (Ada, Parent_Size, "ada__tags__parent_size");
-- This procedure is used in s-finimp and is thus exported manually
procedure Register_Interface_Tag (T : Tag; Interface_T : Tag);
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 IW_Membership.
-- implemented by a type. Required to give support to backward interface
-- conversions and also to IW_Membership.
procedure Register_Tag (T : Tag);
-- Insert the Tag and its associated external_tag in a table for the
-- sake of Internal_Tag
procedure Set_Access_Level (T : Tag; Value : Natural);
-- Sets the accessibility level of the tagged type associated with T
-- in its TSD.
procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive);
-- Set the entry index of a primitive operation in T's TSD table indexed
-- by Position.
procedure Set_Expanded_Name (T : Tag; Value : System.Address);
-- Set the address of the string containing the expanded name
-- in the Dispatch table.
procedure Set_External_Tag (T : Tag; Value : System.Address);
-- Set the address of the string containing the external tag
-- in the Dispatch table.
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_Num_Prim_Ops (T : Tag; Value : Natural);
-- Set the number of primitive operations in the dispatch table of T. This
-- is used for debugging purposes.
procedure Set_Offset_Index
(T : Interface_Tag;
(T : Tag;
Position : Positive;
Value : Positive);
-- Set the offset value of a primitive operation in a secondary dispatch
-- table denoted by T, indexed by Position.
procedure Set_Offset_To_Top
(T : Tag;
Value : System.Storage_Elements.Storage_Offset);
(This : System.Address;
Interface_T : Tag;
Offset_Value : System.Storage_Elements.Storage_Offset);
-- 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 field
-- is always 0; in secondary dispatch tables this is the offset to the base
-- of the enclosing type.
procedure Set_OSD (T : Interface_Tag; Value : System.Address);
-- the dispatch table. In primary dispatch tables the value of "This" is
-- not required (and the compiler passes always the Null_Address value) and
-- the Offset_Value is always cero; in secondary dispatch tables "This"
-- points to the object, Interface_T is the interface for which the
-- secondary dispatch table is being initialized, and Offset_Value is the
-- distance from "This" to the object component containing the tag of the
-- secondary dispatch table.
procedure Set_OSD (T : Tag; Value : System.Address);
-- Given a pointer T to a secondary dispatch table, store the pointer to
-- the record containing the Object Specific Data generated by GNAT.
......@@ -278,26 +334,6 @@ private
-- Set the kind of a primitive operation in T's TSD table indexed by
-- Position.
procedure Set_SSD (T : Tag; Value : System.Address);
-- Given a pointer T to a dispatch Table, stores the pointer to the record
-- containing the Select Specific Data generated by GNAT.
procedure Set_TSD (T : Tag; Value : System.Address);
-- Given a pointer T to a dispatch Table, stores the address of the record
-- containing the Type Specific Data generated by GNAT.
procedure Set_Access_Level (T : Tag; Value : Natural);
-- Sets the accessibility level of the tagged type associated with T
-- in its TSD.
procedure Set_Expanded_Name (T : Tag; Value : System.Address);
-- Set the address of the string containing the expanded name
-- in the Dispatch table.
procedure Set_External_Tag (T : Tag; Value : System.Address);
-- Set the address of the string containing the external tag
-- in the Dispatch table.
procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset);
-- Sets the Offset of the implicit record controller when the object
-- has controlled components. Set to O otherwise.
......@@ -306,6 +342,18 @@ private
-- Set to true if the type has been declared in a context described
-- in E.4 (18).
procedure Set_SSD (T : Tag; Value : System.Address);
-- 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);
-- Set the tagged kind of a type in either a primary or a secondary
-- dispatch table denoted by T.
procedure Set_TSD (T : Tag; Value : System.Address);
-- Given a pointer T to a dispatch Table, stores the address of the record
-- containing the Type Specific Data generated by GNAT.
function SSD (T : Tag) return Select_Specific_Data_Ptr;
-- Given a pointer T to a dispatch Table, retrieves the address of the
-- record containing the Select Specific Data in T's TSD.
......@@ -315,33 +363,31 @@ private
-- record containing the Type Specific Data generated by GNAT.
DT_Prologue_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(3 * (Standard'Address_Size / System.Storage_Unit));
SSE.Storage_Count (4 * (Standard'Address_Size / System.Storage_Unit));
-- Size of the first part of the dispatch table
DT_Signature_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(Standard'Address_Size / System.Storage_Unit);
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 :=
SSE.Storage_Count
(Standard'Address_Size / System.Storage_Unit);
SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
-- Size of the Offset_To_Top field of the Dispatch Table
DT_Typeinfo_Ptr_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(Standard'Address_Size / System.Storage_Unit);
SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
-- Size of the Typeinfo_Ptr field of the Dispatch Table
DT_Entry_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(1 * (Standard'Address_Size / System.Storage_Unit));
SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
-- Size of each primitive operation entry in the Dispatch Table
TSD_Prologue_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(10 * (Standard'Address_Size / System.Storage_Unit));
SSE.Storage_Count (10 * (Standard'Address_Size / System.Storage_Unit));
-- Size of the first part of the type specific data
TSD_Entry_Size : constant SSE.Storage_Count :=
......@@ -396,6 +442,9 @@ private
function To_Address is
new Unchecked_Conversion (Type_Specific_Data_Ptr, System.Address);
function To_Interface_Data_Ptr is
new Unchecked_Conversion (System.Address, Interface_Data_Ptr);
function To_Object_Specific_Data_Ptr is
new Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr);
......@@ -409,10 +458,14 @@ private
function To_Tag_Ptr is
new Unchecked_Conversion (System.Address, Tag_Ptr);
function To_Tagged_Kind_Ptr is
new Unchecked_Conversion (System.Address, Tagged_Kind_Ptr);
-- Primitive dispatching operations are always inlined, to facilitate
-- use in a minimal/no run-time environment for high integrity use.
pragma Inline_Always (CW_Membership);
pragma Inline_Always (Displace);
pragma Inline_Always (IW_Membership);
pragma Inline_Always (Get_Access_Level);
pragma Inline_Always (Get_Entry_Index);
......@@ -421,6 +474,7 @@ private
pragma Inline_Always (Get_Prim_Op_Kind);
pragma Inline_Always (Get_RC_Offset);
pragma Inline_Always (Get_Remotely_Callable);
pragma Inline_Always (Get_Tagged_Kind);
pragma Inline_Always (Inherit_DT);
pragma Inline_Always (Inherit_TSD);
pragma Inline_Always (OSD);
......@@ -430,6 +484,7 @@ private
pragma Inline_Always (Set_Entry_Index);
pragma Inline_Always (Set_Expanded_Name);
pragma Inline_Always (Set_External_Tag);
pragma Inline_Always (Set_Interface_Table);
pragma Inline_Always (Set_Num_Prim_Ops);
pragma Inline_Always (Set_Offset_Index);
pragma Inline_Always (Set_Offset_To_Top);
......@@ -440,6 +495,7 @@ private
pragma Inline_Always (Set_OSD);
pragma Inline_Always (Set_SSD);
pragma Inline_Always (Set_TSD);
pragma Inline_Always (Set_Tagged_Kind);
pragma Inline_Always (SSD);
pragma Inline_Always (TSD);
......
gcc/ada/exp_ch3.adb
......@@ -1760,20 +1760,18 @@ package body Exp_Ch3 is
procedure Init_Secondary_Tags_Internal (Typ : Entity_Id) is
E : Entity_Id;
Aux_N : Node_Id;
Iface : Entity_Id;
begin
if not Is_Interface (Typ) then
-- Climb to the ancestor (if any) handling private types
-- Climb to the ancestor (if any) handling private types
if Present (Full_View (Etype (Typ))) then
if Full_View (Etype (Typ)) /= Typ then
Init_Secondary_Tags_Internal (Full_View (Etype (Typ)));
end if;
elsif Etype (Typ) /= Typ then
Init_Secondary_Tags_Internal (Etype (Typ));
if Present (Full_View (Etype (Typ))) then
if Full_View (Etype (Typ)) /= Typ then
Init_Secondary_Tags_Internal (Full_View (Etype (Typ)));
end if;
elsif Etype (Typ) /= Typ then
Init_Secondary_Tags_Internal (Etype (Typ));
end if;
if Present (Abstract_Interfaces (Typ))
......@@ -1787,6 +1785,8 @@ package body Exp_Ch3 is
Aux_N := Node (ADT);
pragma Assert (Present (Aux_N));
Iface := Find_Interface (Typ, E);
-- Initialize the pointer to the secondary DT
-- associated with the interface
......@@ -1801,15 +1801,23 @@ package body Exp_Ch3 is
New_Reference_To (Aux_N, Loc)));
-- Generate:
-- Set_Offset_To_Top (DT_Ptr, n);
-- Set_Offset_To_Top (Init, Iface'Tag, n);
Append_To (Body_Stmts,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To
(RTE (RE_Set_Offset_To_Top), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Attribute_Name => Name_Address),
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Aux_N, Loc)),
New_Reference_To
(Node (First_Elmt
(Access_Disp_Table (Iface))),
Loc)),
Unchecked_Convert_To (RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
Prefix =>
......@@ -2118,7 +2126,9 @@ package body Exp_Ch3 is
-- Case of composite component with its own Init_Proc
elsif Has_Non_Null_Base_Init_Proc (Typ) then
elsif not Is_Interface (Typ)
and then Has_Non_Null_Base_Init_Proc (Typ)
then
Stmts :=
Build_Initialization_Call
(Loc,
......@@ -4743,18 +4753,15 @@ package body Exp_Ch3 is
Append_Freeze_Actions (Def_Id, Predef_List);
-- Populate the two auxiliary tables used for dispatching
-- asynchronous, conditional and timed selects for tagged
-- asynchronous, conditional and timed selects for synchronized
-- types that implement a limited interface.
if Ada_Version >= Ada_05
and then not Is_Interface (Def_Id)
and then not Is_Abstract (Def_Id)
and then not Is_Controlled (Def_Id)
and then
Implements_Interface
(Typ => Def_Id,
Kind => Any_Limited_Interface,
Check_Parent => True)
and then Is_Concurrent_Record_Type (Def_Id)
and then Implements_Interface (
Typ => Def_Id,
Kind => Any_Limited_Interface,
Check_Parent => True)
then
Append_Freeze_Actions (Def_Id,
Make_Select_Specific_Data_Table (Def_Id));
......@@ -5950,26 +5957,25 @@ package body Exp_Ch3 is
end if;
-- Generate the declarations for the following primitive operations:
-- disp_asynchronous_select
-- disp_conditional_select
-- disp_get_prim_op_kind
-- disp_get_task_id
-- disp_timed_select
-- for limited interfaces and tagged types that implement a limited
-- interface.
-- for limited interfaces and synchronized types that implement a
-- limited interface.
if Ada_Version >= Ada_05
and then
((Is_Interface (Tag_Typ)
and then Is_Limited_Record (Tag_Typ))
or else
(not Is_Abstract (Tag_Typ)
and then not Is_Controlled (Tag_Typ)
and then
Implements_Interface
(Typ => Tag_Typ,
Kind => Any_Limited_Interface,
Check_Parent => True)))
((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ))
or else
(Is_Concurrent_Record_Type (Tag_Typ)
and then Implements_Interface (
Typ => Tag_Typ,
Kind => Any_Limited_Interface,
Check_Parent => True)))
then
Append_To (Res,
Make_Subprogram_Declaration (Loc,
......@@ -6360,20 +6366,18 @@ package body Exp_Ch3 is
-- disp_get_task_id
-- disp_timed_select
-- for limited interfaces and tagged types that implement a limited
-- interface. The interface versions will have null bodies.
-- for limited interfaces and synchronized types that implement a
-- limited interface. The interface versions will have null bodies.
if Ada_Version >= Ada_05
and then
((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ))
or else
(not Is_Abstract (Tag_Typ)
and then not Is_Controlled (Tag_Typ)
and then
Implements_Interface
(Typ => Tag_Typ,
Kind => Any_Limited_Interface,
Check_Parent => True)))
(Is_Concurrent_Record_Type (Tag_Typ)
and then Implements_Interface (
Typ => Tag_Typ,
Kind => Any_Limited_Interface,
Check_Parent => True)))
then
Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ));
......
gcc/ada/exp_ch6.adb
......@@ -4289,8 +4289,7 @@ package body Exp_Ch6 is
Expand_Interface_Thunk
(N => Prim,
Thunk_Alias => Alias (Prim),
Thunk_Id => Thunk_Id,
Thunk_Tag => Iface_Tag);
Thunk_Id => Thunk_Id);
Insert_After (N, New_Thunk);
......@@ -4341,8 +4340,7 @@ package body Exp_Ch6 is
Expand_Interface_Thunk
(N => Ancestor_Iface_Prim,
Thunk_Alias => Prim_Op,
Thunk_Id => Thunk_Id,
Thunk_Tag => Iface_Tag);
Thunk_Id => Thunk_Id);
Insert_After (N, New_Thunk);
......@@ -4401,8 +4399,7 @@ package body Exp_Ch6 is
Expand_Interface_Thunk
(N => Prim,
Thunk_Alias => Prim,
Thunk_Id => Thunk_Id,
Thunk_Tag => Iface_Tag);
Thunk_Id => Thunk_Id);
Insert_After (N, New_Thunk);
Insert_After (New_Thunk,
......
gcc/ada/exp_ch9.adb
......@@ -33,6 +33,7 @@ with Exp_Ch3; use Exp_Ch3;
with Exp_Ch11; use Exp_Ch11;
with Exp_Ch6; use Exp_Ch6;
with Exp_Dbug; use Exp_Dbug;
with Exp_Sel; use Exp_Sel;
with Exp_Smem; use Exp_Smem;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
......@@ -61,10 +62,6 @@ with Uintp; use Uintp;
package body Exp_Ch9 is
--------------------------------
-- Select_Expansion_Utilities --
--------------------------------
-- The following constant establishes the upper bound for the index of
-- an entry family. It is used to limit the allocated size of protected
-- types with defaulted discriminant of an integer type, when the bound
......@@ -75,232 +72,6 @@ package body Exp_Ch9 is
Entry_Family_Bound : constant Int := 2**16;
-- The following package contains helper routines used in the expansion of
-- dispatching asynchronous, conditional and timed selects.
package Select_Expansion_Utilities is
function Build_Abort_Block
(Loc : Source_Ptr;
Abr_Blk_Ent : Entity_Id;
Cln_Blk_Ent : Entity_Id;
Blk : Node_Id) return Node_Id;
-- Generate:
-- begin
-- Blk
-- exception
-- when Abort_Signal => Abort_Undefer;
-- end;
-- Abr_Blk_Ent is the name of the generated block, Cln_Blk_Ent is
-- the name of the encapsulated cleanup block, Blk is the actual
-- block node.
function Build_B
(Loc : Source_Ptr;
Decls : List_Id) return Entity_Id;
-- Generate:
-- B : Boolean := False;
-- Append the object declaration to the list and return the name of
-- the object.
function Build_C
(Loc : Source_Ptr;
Decls : List_Id) return Entity_Id;
-- Generate:
-- C : Ada.Tags.Prim_Op_Kind;
-- Append the object declaration to the list and return the name of
-- the object.
function Build_Cleanup_Block
(Loc : Source_Ptr;
Blk_Ent : Entity_Id;
Stmts : List_Id;
Clean_Ent : Entity_Id) return Node_Id;
-- Generate:
-- declare
-- procedure _clean is
-- begin
-- ...
-- end _clean;
-- begin
-- Stmts
-- at end
-- _clean;
-- end;
-- Blk_Ent is the name of the generated block, Stmts is the list
-- of encapsulated statements and Clean_Ent is the parameter to
-- the _clean procedure.
function Build_S
(Loc : Source_Ptr;
Decls : List_Id;
Obj : Entity_Id;
Call_Ent : Entity_Id) return Entity_Id;
-- Generate:
-- S : constant Integer :=
-- Ada.Tags.Get_Offset_Index (
-- Unchecked_Convert_To (Ada.Tags.Interface_Tag, Obj),
-- DT_Position (Call_Ent));
-- where Obj is the pointer to a secondary table, Call_Ent is the
-- entity of the dispatching call name. Append the object declaration
-- to the list and return its defining identifier.
end Select_Expansion_Utilities;
-----------------------------------------
-- Body for Select_Expansion_Utilities --
-----------------------------------------
package body Select_Expansion_Utilities is
-----------------------
-- Build_Abort_Block --
-----------------------
function Build_Abort_Block
(Loc : Source_Ptr;
Abr_Blk_Ent : Entity_Id;
Cln_Blk_Ent : Entity_Id;
Blk : Node_Id) return Node_Id
is
begin
return
Make_Block_Statement (Loc,
Identifier => New_Reference_To (Abr_Blk_Ent, Loc),
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements =>
New_List (
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier =>
Cln_Blk_Ent,
Label_Construct =>
Blk),
Blk),
Exception_Handlers =>
New_List (
Make_Exception_Handler (Loc,
Exception_Choices =>
New_List (
New_Reference_To (Stand.Abort_Signal, Loc)),
Statements =>
New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (
RE_Abort_Undefer), Loc),
Parameter_Associations => No_List))))));
end Build_Abort_Block;
-------------
-- Build_B --
-------------
function Build_B
(Loc : Source_Ptr;
Decls : List_Id) return Entity_Id
is
B : constant Entity_Id := Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('B'));
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
B,
Object_Definition =>
New_Reference_To (Standard_Boolean, Loc),
Expression =>
New_Reference_To (Standard_False, Loc)));
return B;
end Build_B;
-------------
-- Build_C --
-------------
function Build_C
(Loc : Source_Ptr;
Decls : List_Id) return Entity_Id
is
C : constant Entity_Id := Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('C'));
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
C,
Object_Definition =>
New_Reference_To (RTE (RE_Prim_Op_Kind), Loc)));
return C;
end Build_C;
-------------------------
-- Build_Cleanup_Block --
-------------------------
function Build_Cleanup_Block
(Loc : Source_Ptr;
Blk_Ent : Entity_Id;
Stmts : List_Id;
Clean_Ent : Entity_Id) return Node_Id
is
Cleanup_Block : constant Node_Id :=
Make_Block_Statement (Loc,
Identifier => New_Reference_To (Blk_Ent, Loc),
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts),
Is_Asynchronous_Call_Block => True);
begin
Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);
return Cleanup_Block;
end Build_Cleanup_Block;
-------------
-- Build_S --
-------------
function Build_S
(Loc : Source_Ptr;
Decls : List_Id;
Obj : Entity_Id;
Call_Ent : Entity_Id) return Entity_Id
is
S : constant Entity_Id := Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => S,
Constant_Present => True,
Object_Definition =>
New_Reference_To (Standard_Integer, Loc),
Expression =>
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Interface_Tag), Obj),
Make_Integer_Literal (Loc, DT_Position (Call_Ent))))));
return S;
end Build_S;
end Select_Expansion_Utilities;
package SEU renames Select_Expansion_Utilities;
-----------------------
-- Local Subprograms --
-----------------------
......@@ -2210,6 +1981,7 @@ package body Exp_Ch9 is
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Pid) > 1
or else (Has_Attach_Handler (Pid) and then not Restricted_Profile)
then
Complete := New_Reference_To (RTE (RE_Complete_Entry_Body), Loc);
else
......@@ -2251,6 +2023,7 @@ package body Exp_Ch9 is
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Pid) > 1
or else (Has_Attach_Handler (Pid) and then not Restricted_Profile)
then
Complete :=
New_Reference_To (RTE (RE_Exceptional_Complete_Entry_Body), Loc);
......@@ -2660,6 +2433,7 @@ package body Exp_Ch9 is
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Pid) > 1
or else (Has_Attach_Handler (Pid) and then not Restricted_Profile)
then
Lock_Name := New_Reference_To (RTE (RE_Lock_Entries), Loc);
Service_Name := New_Reference_To (RTE (RE_Service_Entries), Loc);
......@@ -2994,6 +2768,8 @@ package body Exp_Ch9 is
or else Restriction_Active (No_Entry_Queue) = False
or else not Is_Protected_Type (Conctyp)
or else Number_Entries (Conctyp) > 1
or else (Has_Attach_Handler (Conctyp)
and then not Restricted_Profile)
then
X := Make_Defining_Identifier (Loc, Name_uX);
......@@ -3133,6 +2909,8 @@ package body Exp_Ch9 is
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Conctyp) > 1
or else (Has_Attach_Handler (Conctyp)
and then not Restricted_Profile)
then
-- Change the type of the index declaration
......@@ -4898,86 +4676,98 @@ package body Exp_Ch9 is
-- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
-- expanded into:
-- declare
-- B : Boolean := False;
-- Bnn : Communication_Block;
-- C : Ada.Tags.Prim_Op_Kind;
-- P : Parameters := (Param1 .. ParamN)
-- S : constant Integer := DT_Position (<dispatching-call>);
-- U : Boolean;
-- begin
-- disp_get_prim_op_kind (<object>, S, C);
-- if C = POK_Protected_Entry then
-- declare
-- procedure _clean is
-- begin
-- if Enqueued (Bnn) then
-- Cancel_Protected_Entry_Call (Bnn);
-- end if;
-- end _clean;
-- begin
-- begin
-- disp_asynchronous_select
-- (Obj, S, P'address, Bnn, B);
-- Param1 := P.Param1;
-- ...
-- ParamN := P.ParamN;
-- if Enqueued (Bnn) then
-- <abortable-statements>
-- end if;
-- at end
-- _clean;
-- end;
-- exception
-- when Abort_Signal => Abort_Undefer;
-- end;
-- if not Cancelled (Bnn) then
-- <triggering-statements>
-- end if;
-- elsif C = POK_Task_Entry then
-- declare
-- procedure _clean is
-- begin
-- Cancel_Task_Entry_Call (U);
-- end _clean;
-- begin
-- Abort_Defer;
-- disp_asynchronous_select
-- (<object>, S, P'address, Bnn, B);
-- declare
-- B : Boolean := False;
-- Bnn : Communication_Block;
-- C : Ada.Tags.Prim_Op_Kind;
-- K : Ada.Tags.Tagged_Kind :=
-- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
-- P : Parameters := (Param1 .. ParamN);
-- S : Integer;
-- U : Boolean;
-- Param1 := P.Param1;
-- ...
-- ParamN := P.ParamN;
-- begin
-- begin
-- Abort_Undefer;
-- <abortable-statements>
-- at end
-- _clean;
-- end;
-- exception
-- when Abort_Signal => Abort_Undefer;
-- end;
-- if not U then
-- <triggering-statements>
-- end if;
-- end;
-- begin
-- if K = Ada.Tags.TK_Limited_Tagged then
-- <dispatching-call>;
-- <triggering-statements>;
-- else
-- <dispatching-call>;
-- <triggering-statements>
-- end if;
-- else
-- S := Ada.Tags.Get_Offset_Index (Ada.Tags.Tag (<object>),
-- DT_Position (<dispatching-call>));
-- _Disp_Get_Prim_Op_Kind (<object>, S, C);
-- if C = POK_Protected_Entry then
-- declare
-- procedure _clean is
-- begin
-- if Enqueued (Bnn) then
-- Cancel_Protected_Entry_Call (Bnn);
-- end if;
-- end _clean;
-- begin
-- begin
-- _Disp_Asynchronous_Select
-- (<object>, S, P'address, Bnn, B);
-- Param1 := P.Param1;
-- ...
-- ParamN := P.ParamN;
-- if Enqueued (Bnn) then
-- <abortable-statements>
-- end if;
-- at end
-- _clean;
-- end;
-- exception
-- when Abort_Signal => Abort_Undefer;
-- end;
-- if not Cancelled (Bnn) then
-- <triggering-statements>
-- end if;
-- elsif C = POK_Task_Entry then
-- declare
-- procedure _clean is
-- begin
-- Cancel_Task_Entry_Call (U);
-- end _clean;
-- begin
-- Abort_Defer;
-- _Disp_Asynchronous_Select
-- (<object>, S, P'address, Bnn, B);
-- Param1 := P.Param1;
-- ...
-- ParamN := P.ParamN;
-- begin
-- begin
-- Abort_Undefer;
-- <abortable-statements>
-- at end
-- _clean;
-- end;
-- exception
-- when Abort_Signal => Abort_Undefer;
-- end;
-- if not U then
-- <triggering-statements>
-- end if;
-- end;
-- else
-- <dispatching-call>;
-- <triggering-statements>
-- end if;
-- end if;
-- end;
-- The job is to convert this to the asynchronous form
......@@ -5011,6 +4801,7 @@ package body Exp_Ch9 is
Cleanup_Block : Node_Id;
Cleanup_Block_Ent : Entity_Id;
Cleanup_Stmts : List_Id;
Conc_Typ_Stmts : List_Id;
Concval : Node_Id;
Dblock_Ent : Entity_Id;
Decl : Node_Id;
......@@ -5021,6 +4812,7 @@ package body Exp_Ch9 is
Formals : List_Id;
Hdle : List_Id;
Index : Node_Id;
Lim_Typ_Stmts : List_Id;
N_Orig : Node_Id;
Obj : Entity_Id;
Param : Node_Id;
......@@ -5037,6 +4829,7 @@ package body Exp_Ch9 is
B : Entity_Id; -- Call status flag
Bnn : Entity_Id; -- Communication block
C : Entity_Id; -- Call kind
K : Entity_Id; -- Tagged kind
P : Entity_Id; -- Parameter block
S : Entity_Id; -- Primitive operation slot
T : Entity_Id; -- Additional status flag
......@@ -5077,7 +4870,7 @@ package body Exp_Ch9 is
-- Call status flag processing, generate:
-- B : Boolean := False;
B := SEU.Build_B (Loc, Decls);
B := Build_B (Loc, Decls);
-- Communication block processing, generate:
-- Bnn : Communication_Block;
......@@ -5094,7 +4887,13 @@ package body Exp_Ch9 is
-- Call kind processing, generate:
-- C : Ada.Tags.Prim_Op_Kind;
C := SEU.Build_C (Loc, Decls);
C := Build_C (Loc, Decls);
-- Tagged kind processing, generate:
-- K : Ada.Tags.Tagged_Kind :=
-- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
K := Build_K (Loc, Decls, Obj);
-- Parameter block processing
......@@ -5104,12 +4903,9 @@ package body Exp_Ch9 is
(Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
-- Dispatch table slot processing, generate:
-- S : constant Integer :=
-- Ada.Tags.Get_Offset_Index (
-- Unchecked_Convert_To (Ada.Tags.Interface_Tag, Obj),
-- DT_Position (<dispatching-procedure>));
-- S : Integer;
S := SEU.Build_S (Loc, Decls, Obj, Call_Ent);
S := Build_S (Loc, Decls);
-- Additional status flag processing, generate:
......@@ -5122,19 +4918,6 @@ package body Exp_Ch9 is
Object_Definition =>
New_Reference_To (Standard_Boolean, Loc)));
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (
Find_Prim_Op (Etype (Etype (Obj)),
Name_uDisp_Get_Prim_Op_Kind),
Loc),
Parameter_Associations =>
New_List (
New_Copy_Tree (Obj),
New_Reference_To (S, Loc),
New_Reference_To (C, Loc))));
-- ---------------------------------------------------------------
-- Protected entry handling
......@@ -5146,8 +4929,7 @@ package body Exp_Ch9 is
Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
-- Generate:
-- _dispatching_asynchronous_select
-- (<object>, S, P'address, Bnn, B);
-- _Disp_Asynchronous_Select (<object>, S, P'address, Bnn, B);
Prepend_To (Cleanup_Stmts,
Make_Procedure_Call_Statement (Loc,
......@@ -5155,7 +4937,7 @@ package body Exp_Ch9 is
New_Reference_To (
Find_Prim_Op (Etype (Etype (Obj)),
Name_uDisp_Asynchronous_Select),
Loc),
Loc),
Parameter_Associations =>
New_List (
New_Copy_Tree (Obj),
......@@ -5204,8 +4986,8 @@ package body Exp_Ch9 is
Cleanup_Block_Ent :=
Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
Cleanup_Block := SEU.Build_Cleanup_Block (Loc,
Cleanup_Block_Ent, Cleanup_Stmts, Bnn);
Cleanup_Block :=
Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn);
-- Wrap the cleanup block in an exception handling block
......@@ -5224,8 +5006,8 @@ package body Exp_Ch9 is
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Abort_Block_Ent),
SEU.Build_Abort_Block (Loc,
Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
Build_Abort_Block
(Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
-- Generate:
-- if not Cancelled (Bnn) then
......@@ -5258,8 +5040,7 @@ package body Exp_Ch9 is
TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
-- Generate:
-- _dispatching_asynchronous_select
-- (<object>, S, P'address, Bnn, B);
-- _Disp_Asynchronous_Select (<object>, S, P'address, Bnn, B);
Prepend_To (TaskE_Stmts,
Make_Procedure_Call_Statement (Loc,
......@@ -5267,7 +5048,7 @@ package body Exp_Ch9 is
New_Reference_To (
Find_Prim_Op (Etype (Etype (Obj)),
Name_uDisp_Asynchronous_Select),
Loc),
Loc),
Parameter_Associations =>
New_List (
New_Copy_Tree (Obj),
......@@ -5319,8 +5100,8 @@ package body Exp_Ch9 is
Cleanup_Block_Ent :=
Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
Cleanup_Block := SEU.Build_Cleanup_Block (Loc,
Cleanup_Block_Ent, Cleanup_Stmts, T);
Cleanup_Block :=
Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T);
-- Wrap the cleanup block in an exception handling block
......@@ -5339,8 +5120,8 @@ package body Exp_Ch9 is
Defining_Identifier => Abort_Block_Ent));
Append_To (TaskE_Stmts,
SEU.Build_Abort_Block (Loc,
Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
Build_Abort_Block
(Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
-- Generate:
-- if not T then
......@@ -5368,6 +5149,29 @@ package body Exp_Ch9 is
Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall));
-- Generate:
-- S := Ada.Tags.Get_Offset_Index (
-- Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
Conc_Typ_Stmts := New_List (
Build_S_Assignment (Loc, S, Obj, Call_Ent));
-- Generate:
-- _Disp_Get_Prim_Op_Kind (<object>, S, C);
Append_To (Conc_Typ_Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (
Find_Prim_Op (Etype (Etype (Obj)),
Name_uDisp_Get_Prim_Op_Kind),
Loc),
Parameter_Associations =>
New_List (
New_Copy_Tree (Obj),
New_Reference_To (S, Loc),
New_Reference_To (C, Loc))));
-- Generate:
-- if C = POK_Procedure_Entry then
-- ProtE_Stmts
-- elsif C = POK_Task_Entry then
......@@ -5376,7 +5180,7 @@ package body Exp_Ch9 is
-- ProtP_Stmts
-- end if;
Append_To (Stmts,
Append_To (Conc_Typ_Stmts,
Make_If_Statement (Loc,
Condition =>
Make_Op_Eq (Loc,
......@@ -5404,6 +5208,35 @@ package body Exp_Ch9 is
Else_Statements =>
ProtP_Stmts));
-- Generate:
-- <dispatching-call>;
-- <triggering-statements>
Lim_Typ_Stmts := New_Copy_List_Tree (Tstats);
Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall));
-- Generate:
-- if K = Ada.Tags.TK_Limited_Tagged then
-- Lim_Typ_Stmts
-- else
-- Conc_Typ_Stmts
-- end if;
Append_To (Stmts,
Make_If_Statement (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To (K, Loc),
Right_Opnd =>
New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)),
Then_Statements =>
Lim_Typ_Stmts,
Else_Statements =>
Conc_Typ_Stmts));
Rewrite (N,
Make_Block_Statement (Loc,
Declarations =>
......@@ -5866,30 +5699,42 @@ package body Exp_Ch9 is
-- declare
-- B : Boolean := False;
-- C : Ada.Tags.Prim_Op_Kind;
-- K : Ada.Tags.Tagged_Kind :=
-- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
-- P : Parameters := (Param1 .. ParamN);
-- S : constant Integer := DT_Position (<dispatching-procedure>);
-- S : Integer;
-- begin
-- disp_conditional_select (<object>, S, P'address, C, B);
-- if K = Ada.Tags.TK_Limited_Tagged then
-- <dispatching-call>;
-- <triggering-statements>
-- if C = POK_Protected_Entry
-- or else C = POK_Task_Entry
-- then
-- Param1 := P.Param1;
-- ...
-- ParamN := P.ParamN;
-- end if;
-- else
-- S := Ada.Tags.Get_Offset_Index (Ada.Tags.Tag (<object>),
-- DT_Position (<dispatching-call>));
-- if B then
-- if C = POK_Procedure
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure
-- _Disp_Conditional_Select (<object>, S, P'address, C, B);
-- if C = POK_Protected_Entry
-- or else C = POK_Task_Entry
-- then
-- <dispatching-procedure> (<object>, Param1 .. ParamN);
-- Param1 := P.Param1;
-- ...
-- ParamN := P.ParamN;
-- end if;
-- if B then
-- if C = POK_Procedure
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure
-- then
-- <dispatching-call>;
-- end if;
-- <triggering-statements>
-- else
-- <else-statements>
-- end if;
-- <normal-statements>
-- else
-- <else-statements>
-- end if;
-- end;
......@@ -5899,25 +5744,28 @@ package body Exp_Ch9 is
Blk : Node_Id := Entry_Call_Statement (Alt);
Transient_Blk : Node_Id;
Actuals : List_Id;
Blk_Typ : Entity_Id;
Call : Node_Id;
Call_Ent : Entity_Id;
Decl : Node_Id;
Decls : List_Id;
Formals : List_Id;
N_Stats : List_Id;
Obj : Entity_Id;
Param : Node_Id;
Params : List_Id;
Stmt : Node_Id;
Stmts : List_Id;
Unpack : List_Id;
B : Entity_Id; -- Call status flag
C : Entity_Id; -- Call kind
P : Entity_Id; -- Parameter block
S : Entity_Id; -- Primitive operation slot
Actuals : List_Id;
Blk_Typ : Entity_Id;
Call : Node_Id;
Call_Ent : Entity_Id;
Conc_Typ_Stmts : List_Id;
Decl : Node_Id;
Decls : List_Id;
Formals : List_Id;
Lim_Typ_Stmts : List_Id;
N_Stats : List_Id;
Obj : Entity_Id;
Param : Node_Id;
Params : List_Id;
Stmt : Node_Id;
Stmts : List_Id;
Unpack : List_Id;
B : Entity_Id; -- Call status flag
C : Entity_Id; -- Call kind
K : Entity_Id; -- Tagged kind
P : Entity_Id; -- Parameter block
S : Entity_Id; -- Primitive operation slot
begin
if Ada_Version >= Ada_05
......@@ -5931,31 +5779,41 @@ package body Exp_Ch9 is
-- Call status flag processing, generate:
-- B : Boolean := False;
B := SEU.Build_B (Loc, Decls);
B := Build_B (Loc, Decls);
-- Call kind processing, generate:
-- C : Ada.Tags.Prim_Op_Kind;
C := SEU.Build_C (Loc, Decls);
C := Build_C (Loc, Decls);
-- Tagged kind processing, generate:
-- K : Ada.Tags.Tagged_Kind :=
-- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
K := Build_K (Loc, Decls, Obj);
-- Parameter block processing
Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
P := Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals,
Decls, Stmts);
P := Parameter_Block_Pack
(Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
-- Dispatch table slot processing, generate:
-- S : constant Integer :=
-- Ada.Tags.Get_Offset_Index (
-- Unchecked_Convert_To (Ada.Tags.Interface_Tag, Obj),
-- DT_Position (<dispatching-procedure>));
-- S : Integer;
S := SEU.Build_S (Loc, Decls, Obj, Call_Ent);
S := Build_S (Loc, Decls);
-- Generate:
-- _dispatching_conditional_select (<object>, S, P'address, C, B);
-- S := Ada.Tags.Get_Offset_Index (
-- Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
Append_To (Stmts,
Conc_Typ_Stmts := New_List (
Build_S_Assignment (Loc, S, Obj, Call_Ent));
-- Generate:
-- _Disp_Conditional_Select (<object>, S, P'address, C, B);
Append_To (Conc_Typ_Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (
......@@ -5987,7 +5845,7 @@ package body Exp_Ch9 is
-- explicit assignments to their corresponding actuals.
if Present (Unpack) then
Append_To (Stmts,
Append_To (Conc_Typ_Stmts,
Make_If_Statement (Loc,
Condition =>
......@@ -6006,7 +5864,8 @@ package body Exp_Ch9 is
Right_Opnd =>
New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
Then_Statements => Unpack));
Then_Statements =>
Unpack));
end if;
-- Generate:
......@@ -6015,7 +5874,7 @@ package body Exp_Ch9 is
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure
-- then
-- <dispatching-procedure-call>
-- <dispatching-call>
-- end if;
-- <normal-statements>
-- else
......@@ -6056,12 +5915,41 @@ package body Exp_Ch9 is
Then_Statements =>
New_List (Blk)));
Append_To (Stmts,
Append_To (Conc_Typ_Stmts,
Make_If_Statement (Loc,
Condition => New_Reference_To (B, Loc),
Then_Statements => N_Stats,
Else_Statements => Else_Statements (N)));
-- Generate:
-- <dispatching-call>;
-- <triggering-statements>
Lim_Typ_Stmts := New_Copy_List_Tree (Statements (Alt));
Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk));
-- Generate:
-- if K = Ada.Tags.TK_Limited_Tagged then
-- Lim_Typ_Stmts
-- else
-- Conc_Typ_Stmts
-- end if;
Append_To (Stmts,
Make_If_Statement (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To (K, Loc),
Right_Opnd =>
New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)),
Then_Statements =>
Lim_Typ_Stmts,
Else_Statements =>
Conc_Typ_Stmts));
Rewrite (N,
Make_Block_Statement (Loc,
Declarations => Decls,
......@@ -6771,8 +6659,10 @@ package body Exp_Ch9 is
if Has_Entries
and then (Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Num_Entries > 1)
or else Restriction_Active (No_Entry_Queue) = False
or else Num_Entries > 1
or else (Has_Attach_Handler (Pid)
and then not Restricted_Profile))
then
New_Op_Body := Build_Find_Body_Index (Pid);
Insert_After (Current_Node, New_Op_Body);
......@@ -7494,6 +7384,8 @@ package body Exp_Ch9 is
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else E_Count > 1
or else (Has_Attach_Handler (Prottyp)
and then not Restricted_Profile)
then
Body_Arr := Make_Object_Declaration (Loc,
Defining_Identifier => Body_Id,
......@@ -7543,6 +7435,8 @@ package body Exp_Ch9 is
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else E_Count > 1
or else (Has_Attach_Handler (Prottyp)
and then not Restricted_Profile)
then
Sub :=
Make_Subprogram_Declaration (Loc,
......@@ -9538,31 +9432,43 @@ package body Exp_Ch9 is
-- B : Boolean := False;
-- C : Ada.Tags.Prim_Op_Kind;
-- DX : Duration := To_Duration (D)
-- K : Ada.Tags.Tagged_Kind :=
-- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
-- M : Integer :=...;
-- P : Parameters := (Param1 .. ParamN);
-- S : constant Iteger := DT_Position (<dispatching-procedure>);
-- S : Iteger;
-- begin
-- disp_timed_select (<object>, S, P'Address, DX, M, C, B);
-- if K = Ada.Tags.TK_Limited_Tagged then
-- <dispatching-call>;
-- <triggering-statements>
-- if C = POK_Protected_Entry
-- or else C = POK_Task_Entry
-- then
-- Param1 := P.Param1;
-- ...
-- ParamN := P.ParamN;
-- end if;
-- else
-- S := Ada.Tags.Get_Offset_Index (Ada.Tags.Tag (<object>),
-- DT_Position (<dispatching-call>));
-- if B then
-- if C = POK_Procedure
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure
-- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B);
-- if C = POK_Protected_Entry
-- or else C = POK_Task_Entry
-- then
-- T.E;
-- Param1 := P.Param1;
-- ...
-- ParamN := P.ParamN;
-- end if;
-- if B then
-- if C = POK_Procedure
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure
-- then
-- <dispatching-call>;
-- end if;
-- <triggering-statements>
-- else
-- <timed-statements>
-- end if;
-- S1;
-- else
-- S2;
-- end if;
-- end;
......@@ -9578,30 +9484,33 @@ package body Exp_Ch9 is
D_Stats : constant List_Id :=
Statements (Delay_Alternative (N));
Actuals : List_Id;
Blk_Typ : Entity_Id;
Call : Node_Id;
Call_Ent : Entity_Id;
Concval : Node_Id;
D_Conv : Node_Id;
D_Disc : Node_Id;
D_Type : Entity_Id;
Decls : List_Id;
Dummy : Node_Id;
Ename : Node_Id;
Formals : List_Id;
Index : Node_Id;
N_Stats : List_Id;
Obj : Entity_Id;
Param : Node_Id;
Params : List_Id;
Stmt : Node_Id;
Stmts : List_Id;
Unpack : List_Id;
Actuals : List_Id;
Blk_Typ : Entity_Id;
Call : Node_Id;
Call_Ent : Entity_Id;
Conc_Typ_Stmts : List_Id;
Concval : Node_Id;
D_Conv : Node_Id;
D_Disc : Node_Id;
D_Type : Entity_Id;
Decls : List_Id;
Dummy : Node_Id;
Ename : Node_Id;
Formals : List_Id;
Index : Node_Id;
Lim_Typ_Stmts : List_Id;
N_Stats : List_Id;
Obj : Entity_Id;
Param : Node_Id;
Params : List_Id;
Stmt : Node_Id;
Stmts : List_Id;
Unpack : List_Id;
B : Entity_Id; -- Call status flag
C : Entity_Id; -- Call kind
D : Entity_Id; -- Delay
K : Entity_Id; -- Tagged kind
M : Entity_Id; -- Delay mode
P : Entity_Id; -- Parameter block
S : Entity_Id; -- Primitive operation slot
......@@ -9651,7 +9560,7 @@ package body Exp_Ch9 is
-- Generate:
-- B : Boolean := False;
B := SEU.Build_B (Loc, Decls);
B := Build_B (Loc, Decls);
else
-- Generate:
......@@ -9675,7 +9584,7 @@ package body Exp_Ch9 is
-- Generate:
-- C : Ada.Tags.Prim_Op_Kind;
C := SEU.Build_C (Loc, Decls);
C := Build_C (Loc, Decls);
end if;
-- Duration and mode processing
......@@ -9747,20 +9656,30 @@ package body Exp_Ch9 is
if Ada_Version >= Ada_05
and then Nkind (E_Call) = N_Procedure_Call_Statement
then
-- Tagged kind processing, generate:
-- K : Ada.Tags.Tagged_Kind :=
-- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
K := Build_K (Loc, Decls, Obj);
Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
P := Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals,
Decls, Stmts);
-- Dispatch table slot processing, generate:
-- S : constant Integer :=
-- Ada.Tags.Get_Offset_Index (
-- Unchecked_Convert_To (Ada.Tags.Interface_Tag, Obj),
-- DT_Position (<dispatching-procedure>));
-- S : Integer;
S := SEU.Build_S (Loc, Decls, Obj, Call_Ent);
S := Build_S (Loc, Decls);
-- Generate:
-- _dispatching_timed_select (Obj, S, P'address, D, M, C, B);
-- S := Ada.Tags.Get_Offset_Index (
-- Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
Conc_Typ_Stmts := New_List (
Build_S_Assignment (Loc, S, Obj, Call_Ent));
-- Generate:
-- _Disp_Timed_Select (<object>, S, P'address, D, M, C, B);
-- where Obj is the controlling formal parameter, S is the dispatch
-- table slot number of the dispatching operation, P is the wrapped
......@@ -9779,7 +9698,7 @@ package body Exp_Ch9 is
Append_To (Params, New_Reference_To (C, Loc));
Append_To (Params, New_Reference_To (B, Loc));
Append_To (Stmts,
Append_To (Conc_Typ_Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (
......@@ -9804,7 +9723,7 @@ package body Exp_Ch9 is
-- explicit assignments to their corresponding actuals.
if Present (Unpack) then
Append_To (Stmts,
Append_To (Conc_Typ_Stmts,
Make_If_Statement (Loc,
Condition =>
......@@ -9823,7 +9742,8 @@ package body Exp_Ch9 is
Right_Opnd =>
New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
Then_Statements => Unpack));
Then_Statements =>
Unpack));
end if;
-- Generate:
......@@ -9833,11 +9753,11 @@ package body Exp_Ch9 is
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure
-- then
-- <dispatching-procedure-call>
-- <dispatching-call>
-- end if;
-- <normal-statements>
-- <triggering-statements>
-- else
-- <delay-statements>
-- <timed-statements>
-- end if;
N_Stats := New_Copy_List_Tree (E_Stats);
......@@ -9873,11 +9793,41 @@ package body Exp_Ch9 is
Then_Statements =>
New_List (E_Call)));
Append_To (Stmts,
Append_To (Conc_Typ_Stmts,
Make_If_Statement (Loc,
Condition => New_Reference_To (B, Loc),
Then_Statements => N_Stats,
Else_Statements => D_Stats));
-- Generate:
-- <dispatching-call>;
-- <triggering-statements>
Lim_Typ_Stmts := New_Copy_List_Tree (E_Stats);
Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (E_Call));
-- Generate:
-- if K = Ada.Tags.TK_Limited_Tagged then
-- Lim_Typ_Stmts
-- else
-- Conc_Typ_Stmts
-- end if;
Append_To (Stmts,
Make_If_Statement (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To (K, Loc),
Right_Opnd =>
New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)),
Then_Statements =>
Lim_Typ_Stmts,
Else_Statements =>
Conc_Typ_Stmts));
else
-- Skip assignments to temporaries created for in-out parameters.
-- This makes unwarranted assumptions about the shape of the expanded
......@@ -10579,6 +10529,7 @@ package body Exp_Ch9 is
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Ptyp) > 1
or else (Has_Attach_Handler (Ptyp) and then not Restricted)
then
-- Find index mapping function (clumsy but ok for now)
......@@ -10601,6 +10552,8 @@ package body Exp_Ch9 is
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Ptyp) > 1
or else (Has_Attach_Handler (Ptyp)
and then not Restricted)
then
Append_To (L,
Make_Procedure_Call_Statement (Loc,
......
gcc/ada/exp_disp.adb
......@@ -309,11 +309,11 @@ package body Exp_Disp is
Get_Access_Level => RE_Get_Access_Level,
Get_Entry_Index => RE_Get_Entry_Index,
Get_External_Tag => RE_Get_External_Tag,
Get_Offset_Index => RE_Get_Offset_Index,
Get_Prim_Op_Address => RE_Get_Prim_Op_Address,
Get_Prim_Op_Kind => RE_Get_Prim_Op_Kind,
Get_RC_Offset => RE_Get_RC_Offset,
Get_Remotely_Callable => RE_Get_Remotely_Callable,
Get_Tagged_Kind => RE_Get_Tagged_Kind,
Inherit_DT => RE_Inherit_DT,
Inherit_TSD => RE_Inherit_TSD,
Register_Interface_Tag => RE_Register_Interface_Tag,
......@@ -322,6 +322,7 @@ package body Exp_Disp is
Set_Entry_Index => RE_Set_Entry_Index,
Set_Expanded_Name => RE_Set_Expanded_Name,
Set_External_Tag => RE_Set_External_Tag,
Set_Interface_Table => RE_Set_Interface_Table,
Set_Offset_Index => RE_Set_Offset_Index,
Set_OSD => RE_Set_OSD,
Set_Prim_Op_Address => RE_Set_Prim_Op_Address,
......@@ -330,6 +331,7 @@ package body Exp_Disp is
Set_Remotely_Callable => RE_Set_Remotely_Callable,
Set_SSD => RE_Set_SSD,
Set_TSD => RE_Set_TSD,
Set_Tagged_Kind => RE_Set_Tagged_Kind,
TSD_Entry_Size => RE_TSD_Entry_Size,
TSD_Prologue_Size => RE_TSD_Prologue_Size);
......@@ -341,11 +343,11 @@ package body Exp_Disp is
Get_Access_Level => False,
Get_Entry_Index => False,
Get_External_Tag => False,
Get_Offset_Index => False,
Get_Prim_Op_Address => False,
Get_Prim_Op_Kind => False,
Get_Remotely_Callable => False,
Get_RC_Offset => False,
Get_Remotely_Callable => False,
Get_Tagged_Kind => False,
Inherit_DT => True,
Inherit_TSD => True,
Register_Interface_Tag => True,
......@@ -354,6 +356,7 @@ package body Exp_Disp is
Set_Entry_Index => True,
Set_Expanded_Name => True,
Set_External_Tag => True,
Set_Interface_Table => True,
Set_Offset_Index => True,
Set_OSD => True,
Set_Prim_Op_Address => True,
......@@ -362,6 +365,7 @@ package body Exp_Disp is
Set_Remotely_Callable => True,
Set_SSD => True,
Set_TSD => True,
Set_Tagged_Kind => True,
TSD_Entry_Size => False,
TSD_Prologue_Size => False);
......@@ -373,19 +377,20 @@ package body Exp_Disp is
Get_Access_Level => 1,
Get_Entry_Index => 2,
Get_External_Tag => 1,
Get_Offset_Index => 2,
Get_Prim_Op_Address => 2,
Get_Prim_Op_Kind => 2,
Get_RC_Offset => 1,
Get_Remotely_Callable => 1,
Get_Tagged_Kind => 1,
Inherit_DT => 3,
Inherit_TSD => 2,
Register_Interface_Tag => 2,
Register_Interface_Tag => 3,
Register_Tag => 1,
Set_Access_Level => 2,
Set_Entry_Index => 3,
Set_Expanded_Name => 2,
Set_External_Tag => 2,
Set_Interface_Table => 2,
Set_Offset_Index => 3,
Set_OSD => 2,
Set_Prim_Op_Address => 3,
......@@ -394,6 +399,7 @@ package body Exp_Disp is
Set_Remotely_Callable => 2,
Set_SSD => 2,
Set_TSD => 2,
Set_Tagged_Kind => 2,
TSD_Entry_Size => 0,
TSD_Prologue_Size => 0);
......@@ -414,9 +420,13 @@ package body Exp_Disp is
(Prim : Entity_Id;
Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Determine the primitive operation kind of Prim
-- according to its type Typ. Return a reference to an RTE Prim_Op_Kind
-- according to its type Typ. Return a reference to an RE_Prim_Op_Kind
-- enumeration value.
function Tagged_Kind (T : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
-- to an RE_Tagged_Kind enumeration value.
----------------------------
-- Collect_All_Interfaces --
----------------------------
......@@ -426,7 +436,7 @@ package body Exp_Disp is
procedure Add_Interface (Iface : Entity_Id);
-- Add the interface it if is not already in the list
procedure Collect (Typ : Entity_Id);
procedure Collect (Typ : Entity_Id);
-- Subsidiary subprogram used to traverse the whole list
-- of directly and indirectly implemented interfaces
......@@ -453,34 +463,34 @@ package body Exp_Disp is
-------------
procedure Collect (Typ : Entity_Id) is
Nod : constant Node_Id := Type_Definition (Parent (Typ));
Ancestor : Entity_Id;
Id : Node_Id;
Iface : Entity_Id;
Ancestor : Entity_Id;
Nod : Node_Id;
begin
if Ekind (Typ) = E_Record_Type_With_Private then
Nod := Type_Definition (Parent (Full_View (Typ)));
else
Nod := Type_Definition (Parent (Typ));
end if;
pragma Assert (False
or else Nkind (Nod) = N_Derived_Type_Definition
or else Nkind (Nod) = N_Record_Definition);
if Nkind (Nod) = N_Record_Definition then
return;
end if;
-- Include the ancestor if we are generating the whole list
-- of interfaces. This is used to know the size of the table
-- that stores the tag of all the ancestor interfaces.
Ancestor := Etype (Typ);
if Is_Interface (Ancestor) then
Add_Interface (Ancestor);
if Ancestor /= Typ then
Collect (Ancestor);
end if;
if Ancestor /= Typ
and then Ekind (Ancestor) /= E_Record_Type_With_Private
then
Collect (Ancestor);
if Is_Interface (Ancestor) then
Add_Interface (Ancestor);
end if;
-- Traverse the graph of ancestor interfaces
......@@ -1008,7 +1018,10 @@ package body Exp_Disp is
-- Expand_Interface_Conversion --
---------------------------------
procedure Expand_Interface_Conversion (N : Node_Id) is
procedure Expand_Interface_Conversion
(N : Node_Id;
Is_Static : Boolean := True)
is
Loc : constant Source_Ptr := Sloc (N);
Operand : constant Node_Id := Expression (N);
Operand_Typ : Entity_Id := Etype (Operand);
......@@ -1046,6 +1059,40 @@ package body Exp_Disp is
pragma Assert (not Is_Class_Wide_Type (Iface_Typ)
and then Is_Interface (Iface_Typ));
if not Is_Static then
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Displace), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Expression (N)),
Attribute_Name => Name_Address),
New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
Loc))));
Analyze (N);
-- Change the type of the data returned by IW_Convert to
-- indicate that this is a dispatching call.
declare
New_Itype : Entity_Id;
begin
New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
Set_Etype (New_Itype, New_Itype);
Init_Size_Align (New_Itype);
Set_Directly_Designated_Type (New_Itype,
Class_Wide_Type (Iface_Typ));
Rewrite (N, Unchecked_Convert_To (New_Itype,
Relocate_Node (N)));
end;
return;
end if;
Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
pragma Assert (Iface_Tag /= Empty);
......@@ -1359,8 +1406,7 @@ package body Exp_Disp is
function Expand_Interface_Thunk
(N : Node_Id;
Thunk_Alias : Entity_Id;
Thunk_Id : Entity_Id;
Thunk_Tag : Entity_Id) return Node_Id
Thunk_Id : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Actuals : constant List_Id := New_List;
......@@ -1417,7 +1463,7 @@ package body Exp_Disp is
-- type T is access all <<type of the first formal>>
-- S1 := Storage_Offset!(First_formal)
-- - Storage_Offset!(First_Formal.Thunk_Tag'Position)
-- - Offset_To_Top (First_Formal.Tag)
-- ... and the first actual of the call is generated as T!(S1)
......@@ -1452,17 +1498,15 @@ package body Exp_Disp is
New_Reference_To
(Defining_Identifier (First (Formals)), Loc)),
Right_Opnd =>
Unchecked_Convert_To
(RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
New_Reference_To
(Defining_Identifier (First (Formals)), Loc),
Selector_Name =>
New_Occurrence_Of (Thunk_Tag, Loc)),
Attribute_Name => Name_Position))));
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix => New_Reference_To
(Defining_Identifier (First (Formals)),
Loc),
Selector_Name => Make_Identifier (Loc,
Name_uTag))))));
Append_To (Decl, Decl_2);
Append_To (Decl, Decl_1);
......@@ -1474,14 +1518,11 @@ package body Exp_Disp is
(Defining_Identifier (Decl_2),
New_Reference_To (Defining_Identifier (Decl_1), Loc)));
-- Side note: The reverse order of declarations is just to ensure
-- that the call to RE_Print is correct.
else
-- Generate:
--
-- S1 := Storage_Offset!(First_formal'Address)
-- - Storage_Offset!(First_Formal.Thunk_Tag'Position)
-- - Offset_To_Top (First_Formal.Tag)
-- S2 := Tag_Ptr!(S3)
Decl_1 :=
......@@ -1502,17 +1543,15 @@ package body Exp_Disp is
(Defining_Identifier (First (Formals)), Loc),
Attribute_Name => Name_Address)),
Right_Opnd =>
Unchecked_Convert_To
(RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
New_Reference_To
(Defining_Identifier (First (Formals)), Loc),
Selector_Name =>
New_Occurrence_Of (Thunk_Tag, Loc)),
Attribute_Name => Name_Position))));
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix => New_Reference_To
(Defining_Identifier (First (Formals)),
Loc),
Selector_Name => Make_Identifier (Loc,
Name_uTag))))));
Decl_2 :=
Make_Object_Declaration (Loc,
......@@ -1726,6 +1765,8 @@ package body Exp_Disp is
Stmts : constant List_Id := New_List;
begin
-- Null body is generated for interface types
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
......@@ -1738,16 +1779,13 @@ package body Exp_Disp is
New_List (Make_Null_Statement (Loc))));
end if;
if Is_Concurrent_Record_Type (Typ) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
end if;
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
if Present (Conc_Typ) then
if Is_Concurrent_Record_Type (Typ) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
-- Generate:
-- I : Integer := get_entry_index (tag! (<type>VP), S);
-- I : Integer := Get_Entry_Index (tag! (<type>VP), S);
-- where I will be used to capture the entry index of the primitive
-- wrapper at position S.
......@@ -1847,12 +1885,6 @@ package body Exp_Disp is
RTE (RE_Asynchronous_Call), Loc),
Make_Identifier (Loc, Name_uF)))); -- status flag
end if;
-- Implementation for limited tagged types
else
Append_To (Stmts,
Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
end if;
return
......@@ -1914,6 +1946,8 @@ package body Exp_Disp is
Stmts : constant List_Id := New_List;
begin
-- Null body is generated for interface types
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
......@@ -1926,13 +1960,10 @@ package body Exp_Disp is
New_List (Make_Null_Statement (Loc))));
end if;
if Is_Concurrent_Record_Type (Typ) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
end if;
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
if Present (Conc_Typ) then
if Is_Concurrent_Record_Type (Typ) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
-- Generate:
-- I : Integer;
......@@ -1946,22 +1977,20 @@ package body Exp_Disp is
Make_Defining_Identifier (Loc, Name_uI),
Object_Definition =>
New_Reference_To (Standard_Integer, Loc)));
end if;
-- Generate:
-- C := get_prim_op_kind (tag! (<type>VP), S);
-- if C = POK_Procedure
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure;
-- then
-- F := True;
-- return;
-- end if;
-- Generate:
-- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, DT_Ptr, Stmts);
-- if C = POK_Procedure
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure;
-- then
-- F := True;
-- return;
-- end if;
if Present (Conc_Typ) then
SEU.Build_Common_Dispatching_Select_Statements
(Loc, Typ, DT_Ptr, Stmts);
-- Generate:
-- Bnn : Communication_Block;
......@@ -1979,7 +2008,7 @@ package body Exp_Disp is
New_Reference_To (RTE (RE_Communication_Block), Loc)));
-- Generate:
-- I := get_entry_index (tag! (<type>VP), S);
-- I := Get_Entry_Index (tag! (<type>VP), S);
-- I is the entry index and S is the dispatch table slot
......@@ -2097,12 +2126,6 @@ package body Exp_Disp is
RTE (RE_Conditional_Call), Loc),
Make_Identifier (Loc, Name_uF)))); -- status flag
end if;
-- Implementation for limited tagged types
else
Append_To (Stmts,
Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
end if;
return
......@@ -2318,6 +2341,8 @@ package body Exp_Disp is
Stmts : constant List_Id := New_List;
begin
-- Null body is generated for interface types
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
......@@ -2330,13 +2355,10 @@ package body Exp_Disp is
New_List (Make_Null_Statement (Loc))));
end if;
if Is_Concurrent_Record_Type (Typ) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
end if;
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
if Present (Conc_Typ) then
if Is_Concurrent_Record_Type (Typ) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
-- Generate:
-- I : Integer;
......@@ -2350,25 +2372,23 @@ package body Exp_Disp is
Make_Defining_Identifier (Loc, Name_uI),
Object_Definition =>
New_Reference_To (Standard_Integer, Loc)));
end if;
-- Generate:
-- C := get_prim_op_kind (tag! (<type>VP), S);
-- if C = POK_Procedure
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure;
-- then
-- F := True;
-- return;
-- end if;
-- Generate:
-- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, DT_Ptr, Stmts);
-- if C = POK_Procedure
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure;
-- then
-- F := True;
-- return;
-- end if;
if Present (Conc_Typ) then
SEU.Build_Common_Dispatching_Select_Statements
(Loc, Typ, DT_Ptr, Stmts);
-- Generate:
-- I := get_entry_index (tag! (<type>VP), S);
-- I := Get_Entry_Index (tag! (<type>VP), S);
-- I is the entry index and S is the dispatch table slot
......@@ -2469,12 +2489,6 @@ package body Exp_Disp is
Make_Identifier (Loc, Name_uM), -- delay mode
Make_Identifier (Loc, Name_uF)))); -- status flag
end if;
-- Implementation for limited tagged types
else
Append_To (Stmts,
Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
end if;
return
......@@ -2554,6 +2568,7 @@ package body Exp_Disp is
Name_TSD : constant Name_Id := New_External_Name (Tname, 'B');
Name_Exname : constant Name_Id := New_External_Name (Tname, 'E');
Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F');
Name_ITable : Name_Id;
DT : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT);
DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr);
......@@ -2561,17 +2576,21 @@ package body Exp_Disp is
TSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD);
Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname);
No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg);
Generalized_Tag : constant Entity_Id := RTE (RE_Tag);
I_Depth : Int;
Size_Expr_Node : Node_Id;
Old_Tag1 : Node_Id;
Old_Tag2 : Node_Id;
Num_Ifaces : Int;
Nb_Prim : Int;
TSD_Num_Entries : Int;
Typ_Copy : constant Entity_Id := New_Copy (Typ);
AI : Elmt_Id;
ITable : Node_Id;
Generalized_Tag : constant Entity_Id := RTE (RE_Tag);
AI : Elmt_Id;
I_Depth : Int;
Nb_Prim : Int;
Num_Ifaces : Int;
Old_Tag1 : Node_Id;
Old_Tag2 : Node_Id;
Parent_Num_Ifaces : Int;
Size_Expr_Node : Node_Id;
TSD_Num_Entries : Int;
Ancestor_Copy : Entity_Id;
Typ_Copy : Entity_Id;
begin
if not RTE_Available (RE_Tag) then
......@@ -2579,27 +2598,44 @@ package body Exp_Disp is
return New_List;
end if;
-- Collect full list of directly and indirectly implemented interfaces
Set_Parent (Typ_Copy, Parent (Typ));
Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List);
Collect_All_Interfaces (Typ_Copy);
-- Calculate the size of the DT and the TSD
if Is_Interface (Typ) then
-- Abstract interfaces need neither the DT nor the ancestors table.
-- We reserve a single entry for its DT because at run-time the
-- pointer to this dummy DT is the tag of this abstract interface
-- type.
-- pointer to this dummy DT will be used as the tag of this abstract
-- interface type.
Nb_Prim := 1;
TSD_Num_Entries := 0;
Num_Ifaces := 0;
else
-- Calculate the number of entries for the table of interfaces
-- Count the number of interfaces implemented by the ancestors
Parent_Num_Ifaces := 0;
Num_Ifaces := 0;
if Typ /= Etype (Typ) then
Ancestor_Copy := New_Copy (Etype (Typ));
Set_Parent (Ancestor_Copy, Parent (Etype (Typ)));
Set_Abstract_Interfaces (Ancestor_Copy, New_Elmt_List);
Collect_All_Interfaces (Ancestor_Copy);
AI := First_Elmt (Abstract_Interfaces (Ancestor_Copy));
while Present (AI) loop
Parent_Num_Ifaces := Parent_Num_Ifaces + 1;
Next_Elmt (AI);
end loop;
end if;
-- Count the number of additional interfaces implemented by Typ
Typ_Copy := New_Copy (Typ);
Set_Parent (Typ_Copy, Parent (Typ));
Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List);
Collect_All_Interfaces (Typ_Copy);
Num_Ifaces := 0;
AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
while Present (AI) loop
Num_Ifaces := Num_Ifaces + 1;
......@@ -2630,7 +2666,7 @@ package body Exp_Disp is
end loop;
end;
TSD_Num_Entries := I_Depth + Num_Ifaces + 1;
TSD_Num_Entries := I_Depth + 1;
Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
-- If the number of primitives of Typ is less that the number of
......@@ -2650,6 +2686,16 @@ package body Exp_Disp is
Set_Ekind (DT_Ptr, E_Variable);
Set_Is_Statically_Allocated (DT_Ptr);
if not Is_Interface (Typ)
and then Num_Ifaces > 0
then
Name_ITable := New_External_Name (Tname, 'I');
ITable := Make_Defining_Identifier (Loc, Name_ITable);
Set_Ekind (ITable, E_Variable);
Set_Is_Statically_Allocated (ITable);
end if;
Set_Ekind (SSD, E_Variable);
Set_Is_Statically_Allocated (SSD);
......@@ -2842,6 +2888,47 @@ package body Exp_Disp is
Prefix => New_Reference_To (TSD, Loc),
Attribute_Name => Name_Address))));
-- Set the pointer to the Interfaces_Table (if any). Otherwise the
-- corresponding access component is set to null.
if Is_Interface (Typ) then
null;
elsif Num_Ifaces = 0 then
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Set_Interface_Table,
Args => New_List (
New_Reference_To (DT_Ptr, Loc), -- DTptr
New_Reference_To (RTE (RE_Null_Address), Loc)))); -- null
-- Generate the Interface_Table object and set the access
-- component if the TSD to it.
else
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => ITable,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To
(RTE (RE_Interface_Data), Loc),
Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Integer_Literal (Loc,
Num_Ifaces))))));
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Set_Interface_Table,
Args => New_List (
New_Reference_To (DT_Ptr, Loc), -- DTptr
Make_Attribute_Reference (Loc, -- Value
Prefix => New_Reference_To (ITable, Loc),
Attribute_Name => Name_Address))));
end if;
-- Generate:
-- Set_Num_Prim_Ops (T'Tag, Nb_Prim)
......@@ -2858,39 +2945,53 @@ package body Exp_Disp is
and then not Is_Interface (Typ)
and then not Is_Abstract (Typ)
and then not Is_Controlled (Typ)
and then Implements_Interface (
Typ => Typ,
Kind => Any_Limited_Interface,
Check_Parent => True)
and then (Nb_Prim - Default_Prim_Op_Count) > 0
then
-- Generate the Select Specific Data table for tagged types that
-- implement a synchronized interface. The size of the table is
-- constrained by the number of non-predefined primitive operations.
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => SSD,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To (
RTE (RE_Select_Specific_Data), Loc),
Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Integer_Literal (Loc,
Nb_Prim - Default_Prim_Op_Count))))));
-- Set the pointer to the Select Specific Data table in the TSD
-- Generate:
-- Set_Type_Kind (T'Tag, Type_Kind (Typ));
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Set_SSD,
Action => Set_Tagged_Kind,
Args => New_List (
New_Reference_To (DT_Ptr, Loc), -- DTptr
Make_Attribute_Reference (Loc, -- Value
Prefix => New_Reference_To (SSD, Loc),
Attribute_Name => Name_Address))));
Tagged_Kind (Typ)))); -- Value
-- Generate the Select Specific Data table for synchronized
-- types that implement a synchronized interface. The size
-- of the table is constrained by the number of non-predefined
-- primitive operations.
if Is_Concurrent_Record_Type (Typ)
and then Implements_Interface (
Typ => Typ,
Kind => Any_Limited_Interface,
Check_Parent => True)
and then (Nb_Prim - Default_Prim_Op_Count) > 0
then
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => SSD,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To (
RTE (RE_Select_Specific_Data), Loc),
Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Integer_Literal (Loc,
Nb_Prim - Default_Prim_Op_Count))))));
-- Set the pointer to the Select Specific Data table in the TSD
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Set_SSD,
Args => New_List (
New_Reference_To (DT_Ptr, Loc), -- DTptr
Make_Attribute_Reference (Loc, -- Value
Prefix => New_Reference_To (SSD, Loc),
Attribute_Name => Name_Address))));
end if;
end if;
-- Generate: Exname : constant String := full_qualified_name (typ);
......@@ -3158,12 +3259,13 @@ package body Exp_Disp is
end;
-- Generate:
-- Set_Offset_To_Top (DT_Ptr, 0);
-- Set_Offset_To_Top (0, DT_Ptr, 0);
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
Parameter_Associations => New_List (
New_Reference_To (RTE (RE_Null_Address), Loc),
New_Reference_To (DT_Ptr, Loc),
Make_Integer_Literal (Loc, Uint_0))));
end if;
......@@ -3222,31 +3324,82 @@ package body Exp_Disp is
Then_Statements => Elab_Code));
-- Ada 2005 (AI-251): Register the tag of the interfaces into
-- the table of implemented interfaces and ...
-- the table of implemented interfaces.
if not Is_Interface (Typ)
and then Present (Abstract_Interfaces (Typ_Copy))
and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ_Copy))
and then Num_Ifaces > 0
then
AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
while Present (AI) loop
declare
Position : Int;
-- Generate:
-- Register_Interface (DT_Ptr, Interface'Tag);
begin
-- If the parent is an interface we must generate code to register
-- all its interfaces; otherwise this code is not needed because
-- Inherit_TSD has already inherited such interfaces.
Append_To (Result,
Make_DT_Access_Action (Typ,
Action => Register_Interface_Tag,
Args => New_List (
Node1 => New_Reference_To (DT_Ptr, Loc),
Node2 => New_Reference_To
(Node
(First_Elmt
(Access_Disp_Table (Node (AI)))),
Loc))));
if Is_Interface (Etype (Typ)) then
Position := 1;
Next_Elmt (AI);
end loop;
AI := First_Elmt (Abstract_Interfaces (Ancestor_Copy));
while Present (AI) loop
-- Generate:
-- Register_Interface (DT_Ptr, Interface'Tag);
Append_To (Result,
Make_DT_Access_Action (Typ,
Action => Register_Interface_Tag,
Args => New_List (
Node1 => New_Reference_To (DT_Ptr, Loc),
Node2 => New_Reference_To
(Node
(First_Elmt
(Access_Disp_Table (Node (AI)))),
Loc),
Node3 => Make_Integer_Literal (Loc, Position))));
Position := Position + 1;
Next_Elmt (AI);
end loop;
end if;
-- Register the interfaces that are not implemented by the
-- ancestor
if Present (Abstract_Interfaces (Typ_Copy)) then
AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
-- Skip the interfaces implemented by the ancestor
for Count in 1 .. Parent_Num_Ifaces loop
Next_Elmt (AI);
end loop;
-- Register the additional interfaces
Position := Parent_Num_Ifaces + 1;
while Present (AI) loop
-- Generate:
-- Register_Interface (DT_Ptr, Interface'Tag);
Append_To (Result,
Make_DT_Access_Action (Typ,
Action => Register_Interface_Tag,
Args => New_List (
Node1 => New_Reference_To (DT_Ptr, Loc),
Node2 => New_Reference_To
(Node
(First_Elmt
(Access_Disp_Table (Node (AI)))),
Loc),
Node3 => Make_Integer_Literal (Loc, Position))));
Position := Position + 1;
Next_Elmt (AI);
end loop;
end if;
pragma Assert (Position = Num_Ifaces + 1);
end;
end if;
return Result;
......@@ -3471,7 +3624,7 @@ package body Exp_Disp is
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Integer_Literal (Loc,
Nb_Prim - Default_Prim_Op_Count))))));
Nb_Prim - Default_Prim_Op_Count + 1))))));
-- Generate:
-- Ada.Tags.Set_OSD (Iface_DT_Ptr, OSD);
......@@ -3480,63 +3633,12 @@ package body Exp_Disp is
Make_DT_Access_Action (Typ,
Action => Set_OSD,
Args => New_List (
New_Reference_To (Iface_DT_Ptr, Loc),
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Iface_DT_Ptr, Loc)),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (OSD, Loc),
Attribute_Name => Name_Address))));
-- Offset table creation
if not Is_Interface (Typ)
and then not Is_Abstract (Typ)
and then not Is_Controlled (Typ)
and then Implements_Interface
(Typ => Typ,
Kind => Any_Limited_Interface,
Check_Parent => True)
and then (Nb_Prim - Default_Prim_Op_Count) > 0
then
declare
Prim : Entity_Id;
Prim_Alias : Entity_Id;
Prim_Elmt : Elmt_Id;
begin
-- Step 2: Populate the OSD table
Prim_Alias := Empty;
Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
if Present (Abstract_Interface_Alias (Prim)) then
Prim_Alias := Abstract_Interface_Alias (Prim);
end if;
if Present (Prim_Alias)
and then Present (First_Entity (Prim_Alias))
and then Etype (First_Entity (Prim_Alias)) = Iface
then
-- Generate:
-- Ada.Tags.Set_Offset_Index (
-- Iface_DT_Ptr, secondary_DT_Pos, primary_DT_pos);
Append_To (Result,
Make_DT_Access_Action (Iface,
Action => Set_Offset_Index,
Args => New_List (
New_Reference_To (Iface_DT_Ptr, Loc),
Make_Integer_Literal (Loc, DT_Position (Prim_Alias)),
Make_Integer_Literal (Loc, DT_Position (Prim)))));
Prim_Alias := Empty;
end if;
Next_Elmt (Prim_Elmt);
end loop;
end;
end if;
-- Generate:
-- Set_Num_Prim_Ops (T'Tag, Nb_Prim)
......@@ -3548,6 +3650,73 @@ package body Exp_Disp is
New_Reference_To (Iface_DT_Ptr, Loc)),
Make_Integer_Literal (Loc, Nb_Prim))));
if Ada_Version >= Ada_05
and then not Is_Interface (Typ)
and then not Is_Abstract (Typ)
and then not Is_Controlled (Typ)
then
-- Generate:
-- Set_Tagged_Kind (Iface'Tag, Tagged_Kind (Iface));
Append_To (Result,
Make_DT_Access_Action (Typ,
Action => Set_Tagged_Kind,
Args => New_List (
Unchecked_Convert_To (RTE (RE_Tag), -- DTptr
New_Reference_To (Iface_DT_Ptr, Loc)),
Tagged_Kind (Typ)))); -- Value
if Is_Concurrent_Record_Type (Typ)
and then Implements_Interface (
Typ => Typ,
Kind => Any_Limited_Interface,
Check_Parent => True)
and then (Nb_Prim - Default_Prim_Op_Count) > 0
then
declare
Prim : Entity_Id;
Prim_Alias : Entity_Id;
Prim_Elmt : Elmt_Id;
begin
-- Step 2: Populate the OSD table
Prim_Alias := Empty;
Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
if Present (Abstract_Interface_Alias (Prim)) then
Prim_Alias := Abstract_Interface_Alias (Prim);
end if;
if Present (Prim_Alias)
and then Present (First_Entity (Prim_Alias))
and then Etype (First_Entity (Prim_Alias)) = Iface
then
-- Generate:
-- Ada.Tags.Set_Offset_Index (Tag (Iface_DT_Ptr),
-- Secondary_DT_Pos, Primary_DT_pos);
Append_To (Result,
Make_DT_Access_Action (Iface,
Action => Set_Offset_Index,
Args => New_List (
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Iface_DT_Ptr, Loc)),
Make_Integer_Literal (Loc,
DT_Position (Prim_Alias)),
Make_Integer_Literal (Loc,
DT_Position (Prim)))));
Prim_Alias := Empty;
end if;
Next_Elmt (Prim_Elmt);
end loop;
end;
end if;
end if;
end Make_Secondary_DT;
-------------------------------------
......@@ -4413,6 +4582,49 @@ package body Exp_Disp is
end if;
end Set_Default_Constructor;
-----------------
-- Tagged_Kind --
-----------------
function Tagged_Kind (T : Entity_Id) return Node_Id is
Conc_Typ : Entity_Id;
Loc : constant Source_Ptr := Sloc (T);
begin
pragma Assert (Is_Tagged_Type (T));
-- Abstract kinds
if Is_Abstract (T) then
if Is_Limited_Record (T) then
return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
else
return New_Reference_To (RTE (RE_TK_Abstract_Tagged), Loc);
end if;
-- Concurrent kinds
elsif Is_Concurrent_Record_Type (T) then
Conc_Typ := Corresponding_Concurrent_Type (T);
if Ekind (Conc_Typ) = E_Protected_Type then
return New_Reference_To (RTE (RE_TK_Protected), Loc);
else
pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
return New_Reference_To (RTE (RE_TK_Task), Loc);
end if;
-- Regular tagged kinds
else
if Is_Limited_Record (T) then
return New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc);
else
return New_Reference_To (RTE (RE_TK_Tagged), Loc);
end if;
end if;
end Tagged_Kind;
--------------
-- Write_DT --
--------------
......
gcc/ada/exp_disp.ads
......@@ -184,11 +184,11 @@ package Exp_Disp is
Get_Access_Level,
Get_Entry_Index,
Get_External_Tag,
Get_Offset_Index,
Get_Prim_Op_Address,
Get_Prim_Op_Kind,
Get_RC_Offset,
Get_Remotely_Callable,
Get_Tagged_Kind,
Inherit_DT,
Inherit_TSD,
Register_Interface_Tag,
......@@ -197,6 +197,7 @@ package Exp_Disp is
Set_Entry_Index,
Set_Expanded_Name,
Set_External_Tag,
Set_Interface_Table,
Set_Offset_Index,
Set_OSD,
Set_Prim_Op_Address,
......@@ -205,6 +206,7 @@ package Exp_Disp is
Set_Remotely_Callable,
Set_SSD,
Set_TSD,
Set_Tagged_Kind,
TSD_Entry_Size,
TSD_Prologue_Size);
......@@ -217,16 +219,17 @@ package Exp_Disp is
-- Ada 2005 (AI-251): Displace all the actuals corresponding to class-wide
-- interfaces to reference the interface tag of the actual object
procedure Expand_Interface_Conversion (N : Node_Id);
procedure Expand_Interface_Conversion
(N : Node_Id;
Is_Static : Boolean := True);
-- Ada 2005 (AI-251): N is a type-conversion node. Reference the base of
-- the object to give access to the interface tag associated with the
-- secondary dispatch table
-- secondary dispatch table.
function Expand_Interface_Thunk
(N : Node_Id;
Thunk_Alias : Node_Id;
Thunk_Id : Entity_Id;
Thunk_Tag : Entity_Id) return Node_Id;
Thunk_Id : Entity_Id) return Node_Id;
-- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
-- generate additional subprograms (thunks) to have a layout compatible
-- with the C++ ABI. The thunk modifies the value of the first actual of
......
gcc/ada/exp_sel.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ S E L --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Einfo; use Einfo;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Rtsfind; use Rtsfind;
with Stand; use Stand;
with Tbuild; use Tbuild;
package body Exp_Sel is
-----------------------
-- Build_Abort_Block --
-----------------------
function Build_Abort_Block
(Loc : Source_Ptr;
Abr_Blk_Ent : Entity_Id;
Cln_Blk_Ent : Entity_Id;
Blk : Node_Id) return Node_Id
is
begin
return
Make_Block_Statement (Loc,
Identifier => New_Reference_To (Abr_Blk_Ent, Loc),
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements =>
New_List (
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier =>
Cln_Blk_Ent,
Label_Construct =>
Blk),
Blk),
Exception_Handlers =>
New_List (
Make_Exception_Handler (Loc,
Exception_Choices =>
New_List (
New_Reference_To (Stand.Abort_Signal, Loc)),
Statements =>
New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (
RE_Abort_Undefer), Loc),
Parameter_Associations => No_List))))));
end Build_Abort_Block;
-------------
-- Build_B --
-------------
function Build_B
(Loc : Source_Ptr;
Decls : List_Id) return Entity_Id
is
B : constant Entity_Id := Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('B'));
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
B,
Object_Definition =>
New_Reference_To (Standard_Boolean, Loc),
Expression =>
New_Reference_To (Standard_False, Loc)));
return B;
end Build_B;
-------------
-- Build_C --
-------------
function Build_C
(Loc : Source_Ptr;
Decls : List_Id) return Entity_Id
is
C : constant Entity_Id := Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('C'));
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
C,
Object_Definition =>
New_Reference_To (RTE (RE_Prim_Op_Kind), Loc)));
return C;
end Build_C;
-------------------------
-- Build_Cleanup_Block --
-------------------------
function Build_Cleanup_Block
(Loc : Source_Ptr;
Blk_Ent : Entity_Id;
Stmts : List_Id;
Clean_Ent : Entity_Id) return Node_Id
is
Cleanup_Block : constant Node_Id :=
Make_Block_Statement (Loc,
Identifier => New_Reference_To (Blk_Ent, Loc),
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts),
Is_Asynchronous_Call_Block => True);
begin
Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);
return Cleanup_Block;
end Build_Cleanup_Block;
-------------
-- Build_K --
-------------
function Build_K
(Loc : Source_Ptr;
Decls : List_Id;
Obj : Entity_Id) return Entity_Id
is
K : constant Entity_Id := Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('K'));
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => K,
Object_Definition =>
New_Reference_To (RTE (RE_Tagged_Kind), Loc),
Expression =>
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Get_Tagged_Kind), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Tag), Obj)))));
return K;
end Build_K;
-------------
-- Build_S --
-------------
function Build_S
(Loc : Source_Ptr;
Decls : List_Id) return Entity_Id
is
S : constant Entity_Id := Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => S,
Object_Definition =>
New_Reference_To (Standard_Integer, Loc)));
return S;
end Build_S;
------------------------
-- Build_S_Assignment --
------------------------
function Build_S_Assignment
(Loc : Source_Ptr;
S : Entity_Id;
Obj : Entity_Id;
Call_Ent : Entity_Id) return Node_Id
is
begin
return
Make_Assignment_Statement (Loc,
Name => New_Reference_To (S, Loc),
Expression =>
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Tag), Obj),
Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
end Build_S_Assignment;
end Exp_Sel;
gcc/ada/exp_sel.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ S E L --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Routines used in Chapter 9 for the expansion of dispatching triggers in
-- select statements (Ada 2005: AI-345)
with Types; use Types;
package Exp_Sel is
function Build_Abort_Block
(Loc : Source_Ptr;
Abr_Blk_Ent : Entity_Id;
Cln_Blk_Ent : Entity_Id;
Blk : Node_Id) return Node_Id;
-- Generate:
-- begin
-- Blk
-- exception
-- when Abort_Signal => Abort_Undefer;
-- end;
-- Abr_Blk_Ent is the name of the generated block, Cln_Blk_Ent is the name
-- of the encapsulated cleanup block, Blk is the actual block name.
function Build_B
(Loc : Source_Ptr;
Decls : List_Id) return Entity_Id;
-- Generate:
-- B : Boolean := False;
-- Append the object declaration to the list and return its defining
-- identifier.
function Build_C
(Loc : Source_Ptr;
Decls : List_Id) return Entity_Id;
-- Generate:
-- C : Ada.Tags.Prim_Op_Kind;
-- Append the object declaration to the list and return its defining
-- identifier.
function Build_Cleanup_Block
(Loc : Source_Ptr;
Blk_Ent : Entity_Id;
Stmts : List_Id;
Clean_Ent : Entity_Id) return Node_Id;
-- Generate:
-- declare
-- procedure _clean is
-- begin
-- ...
-- end _clean;
-- begin
-- Stmts
-- at end
-- _clean;
-- end;
-- Blk_Ent is the name of the generated block, Stmts is the list of
-- encapsulated statements and Clean_Ent is the parameter to the
-- _clean procedure.
function Build_K
(Loc : Source_Ptr;
Decls : List_Id;
Obj : Entity_Id) return Entity_Id;
-- Generate
-- K : Ada.Tags.Tagged_Kind :=
-- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (Obj));
-- where Obj is the pointer to a secondary table. Append the object
-- declaration to the list and return its defining identifier.
function Build_S
(Loc : Source_Ptr;
Decls : List_Id) return Entity_Id;
-- Generate:
-- S : Integer;
-- Append the object declaration to the list and return its defining
-- identifier.
function Build_S_Assignment
(Loc : Source_Ptr;
S : Entity_Id;
Obj : Entity_Id;
Call_Ent : Entity_Id) return Node_Id;
-- Generate:
-- S := Ada.Tags.Get_Offset_Index (
-- Ada.Tags.Tag (Obj), DT_Position (Call_Ent));
-- where Obj is the pointer to a secondary table, Call_Ent is the entity
-- of the dispatching call name. Return the generated assignment.
end Exp_Sel;
gcc/ada/rtsfind.ads
......@@ -120,6 +120,7 @@ package Rtsfind is
Ada_Streams,
Ada_Tags,
Ada_Task_Identification,
Ada_Task_Termination,
-- Children of Ada.Calendar
......@@ -488,10 +489,12 @@ package Rtsfind is
RE_Stream_Access, -- Ada.Streams.Stream_IO
RE_Abstract_Interface, -- Ada.Tags
RE_Addr_Ptr, -- Ada.Tags
RE_Address_Array, -- Ada.Tags
RE_CW_Membership, -- Ada.Tags
RE_IW_Membership, -- Ada.Tags
RE_Descendant_Tag, -- Ada.Tags
RE_Displace, -- Ada.Tags
RE_DT_Entry_Size, -- Ada.Tags
RE_DT_Prologue_Size, -- Ada.Tags
RE_External_Tag, -- Ada.Tags
......@@ -503,11 +506,16 @@ package Rtsfind is
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_Inherit_DT, -- Ada.Tags
RE_Inherit_TSD, -- Ada.Tags
RE_Interface_Data, -- Ada.Tags
RE_Interface_Tag, -- Ada.Tags
RE_Internal_Tag, -- Ada.Tags
RE_Is_Descendant_At_Same_Level, -- Ada.Tags
RE_IW_Membership, -- Ada.Tags
RE_Object_Specific_Data, -- Ada.Tags
RE_Offset_To_Top, -- Ada.Tags
RE_POK_Function, -- Ada.Tags
RE_POK_Procedure, -- Ada.Tags
RE_POK_Protected_Entry, -- Ada.Tags
......@@ -517,13 +525,16 @@ package Rtsfind is
RE_POK_Task_Function, -- Ada.Tags
RE_POK_Task_Procedure, -- Ada.Tags
RE_Prim_Op_Kind, -- Ada.Tags
RE_Primary_DT, -- Ada.Tags
RE_Register_Interface_Tag, -- Ada.Tags
RE_Register_Tag, -- Ada.Tags
RE_Secondary_DT, -- Ada.Tags
RE_Select_Specific_Data, -- Ada.Tags
RE_Set_Access_Level, -- Ada.Tags
RE_Set_Entry_Index, -- Ada.Tags
RE_Set_Expanded_Name, -- Ada.Tags
RE_Set_External_Tag, -- Ada.Tags
RE_Set_Interface_Table, -- Ada.Tags
RE_Set_Num_Prim_Ops, -- Ada.Tags
RE_Set_Offset_Index, -- Ada.Tags
RE_Set_Offset_To_Top, -- Ada.Tags
......@@ -533,17 +544,20 @@ package Rtsfind is
RE_Set_RC_Offset, -- Ada.Tags
RE_Set_Remotely_Callable, -- Ada.Tags
RE_Set_SSD, -- Ada.Tags
RE_Set_Tagged_Kind, -- Ada.Tags
RE_Set_TSD, -- Ada.Tags
RE_Tag, -- Ada.Tags
RE_Tag_Error, -- Ada.Tags
RE_Tagged_Kind, -- Ada.Tags
RE_TSD_Entry_Size, -- Ada.Tags
RE_TSD_Prologue_Size, -- Ada.Tags
RE_Interface_Tag, -- Ada.Tags
RE_Tag, -- Ada.Tags
RE_Address_Array, -- Ada.Tags
RE_TK_Abstract_Limited_Tagged, -- Ada.Tags
RE_TK_Abstract_Tagged, -- Ada.Tags
RE_TK_Limited_Tagged, -- Ada.Tags
RE_TK_Protected, -- Ada.Tags
RE_TK_Tagged, -- Ada.Tags
RE_TK_Task, -- Ada.Tags
RE_Valid_Signature, -- Ada.Tags
RE_Primary_DT, -- Ada.Tags
RE_Secondary_DT, -- Ada.Tags
RE_Abstract_Interface, -- Ada.Tags
RE_Abort_Task, -- Ada.Task_Identification
RE_Current_Task, -- Ada.Task_Identification
......@@ -1629,10 +1643,12 @@ package Rtsfind is
RE_Stream_Access => Ada_Streams_Stream_IO,
RE_Abstract_Interface => Ada_Tags,
RE_Addr_Ptr => Ada_Tags,
RE_Address_Array => Ada_Tags,
RE_CW_Membership => Ada_Tags,
RE_IW_Membership => Ada_Tags,
RE_Descendant_Tag => Ada_Tags,
RE_Displace => Ada_Tags,
RE_DT_Entry_Size => Ada_Tags,
RE_DT_Prologue_Size => Ada_Tags,
RE_External_Tag => Ada_Tags,
......@@ -1644,11 +1660,16 @@ package Rtsfind is
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_Inherit_DT => Ada_Tags,
RE_Inherit_TSD => Ada_Tags,
RE_Interface_Data => Ada_Tags,
RE_Interface_Tag => Ada_Tags,
RE_Internal_Tag => Ada_Tags,
RE_Is_Descendant_At_Same_Level => Ada_Tags,
RE_IW_Membership => Ada_Tags,
RE_Object_Specific_Data => Ada_Tags,
RE_Offset_To_Top => Ada_Tags,
RE_POK_Function => Ada_Tags,
RE_POK_Procedure => Ada_Tags,
RE_POK_Protected_Entry => Ada_Tags,
......@@ -1658,13 +1679,16 @@ package Rtsfind is
RE_POK_Task_Function => Ada_Tags,
RE_POK_Task_Procedure => Ada_Tags,
RE_Prim_Op_Kind => Ada_Tags,
RE_Primary_DT => Ada_Tags,
RE_Register_Interface_Tag => Ada_Tags,
RE_Register_Tag => Ada_Tags,
RE_Secondary_DT => Ada_Tags,
RE_Select_Specific_Data => Ada_Tags,
RE_Set_Access_Level => Ada_Tags,
RE_Set_Entry_Index => Ada_Tags,
RE_Set_Expanded_Name => Ada_Tags,
RE_Set_External_Tag => Ada_Tags,
RE_Set_Interface_Table => Ada_Tags,
RE_Set_Num_Prim_Ops => Ada_Tags,
RE_Set_Offset_Index => Ada_Tags,
RE_Set_Offset_To_Top => Ada_Tags,
......@@ -1674,17 +1698,20 @@ package Rtsfind is
RE_Set_RC_Offset => Ada_Tags,
RE_Set_Remotely_Callable => Ada_Tags,
RE_Set_SSD => Ada_Tags,
RE_Set_Tagged_Kind => Ada_Tags,
RE_Set_TSD => Ada_Tags,
RE_Tag => Ada_Tags,
RE_Tag_Error => Ada_Tags,
RE_Tagged_Kind => Ada_Tags,
RE_TSD_Entry_Size => Ada_Tags,
RE_TSD_Prologue_Size => Ada_Tags,
RE_Interface_Tag => Ada_Tags,
RE_Tag => Ada_Tags,
RE_Address_Array => Ada_Tags,
RE_TK_Abstract_Limited_Tagged => Ada_Tags,
RE_TK_Abstract_Tagged => Ada_Tags,
RE_TK_Limited_Tagged => Ada_Tags,
RE_TK_Protected => Ada_Tags,
RE_TK_Tagged => Ada_Tags,
RE_TK_Task => Ada_Tags,
RE_Valid_Signature => Ada_Tags,
RE_Primary_DT => Ada_Tags,
RE_Secondary_DT => Ada_Tags,
RE_Abstract_Interface => Ada_Tags,
RE_Abort_Task => Ada_Task_Identification,
RE_Current_Task => Ada_Task_Identification,
......
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