Commit 4d744221 by Javier Miranda Committed by Arnaud Charlet

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
...@@ -1760,20 +1760,18 @@ package body Exp_Ch3 is ...@@ -1760,20 +1760,18 @@ package body Exp_Ch3 is
procedure Init_Secondary_Tags_Internal (Typ : Entity_Id) is procedure Init_Secondary_Tags_Internal (Typ : Entity_Id) is
E : Entity_Id; E : Entity_Id;
Aux_N : Node_Id; Aux_N : Node_Id;
Iface : Entity_Id;
begin 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
if Present (Full_View (Etype (Typ))) then Init_Secondary_Tags_Internal (Full_View (Etype (Typ)));
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; end if;
elsif Etype (Typ) /= Typ then
Init_Secondary_Tags_Internal (Etype (Typ));
end if; end if;
if Present (Abstract_Interfaces (Typ)) if Present (Abstract_Interfaces (Typ))
...@@ -1787,6 +1785,8 @@ package body Exp_Ch3 is ...@@ -1787,6 +1785,8 @@ package body Exp_Ch3 is
Aux_N := Node (ADT); Aux_N := Node (ADT);
pragma Assert (Present (Aux_N)); pragma Assert (Present (Aux_N));
Iface := Find_Interface (Typ, E);
-- Initialize the pointer to the secondary DT -- Initialize the pointer to the secondary DT
-- associated with the interface -- associated with the interface
...@@ -1801,15 +1801,23 @@ package body Exp_Ch3 is ...@@ -1801,15 +1801,23 @@ package body Exp_Ch3 is
New_Reference_To (Aux_N, Loc))); New_Reference_To (Aux_N, Loc)));
-- Generate: -- Generate:
-- Set_Offset_To_Top (DT_Ptr, n); -- Set_Offset_To_Top (Init, Iface'Tag, n);
Append_To (Body_Stmts, Append_To (Body_Stmts,
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To Name => New_Reference_To
(RTE (RE_Set_Offset_To_Top), Loc), (RTE (RE_Set_Offset_To_Top), Loc),
Parameter_Associations => New_List ( Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Attribute_Name => Name_Address),
Unchecked_Convert_To (RTE (RE_Tag), 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), Unchecked_Convert_To (RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix =>
...@@ -2118,7 +2126,9 @@ package body Exp_Ch3 is ...@@ -2118,7 +2126,9 @@ package body Exp_Ch3 is
-- Case of composite component with its own Init_Proc -- 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 := Stmts :=
Build_Initialization_Call Build_Initialization_Call
(Loc, (Loc,
...@@ -4743,18 +4753,15 @@ package body Exp_Ch3 is ...@@ -4743,18 +4753,15 @@ package body Exp_Ch3 is
Append_Freeze_Actions (Def_Id, Predef_List); Append_Freeze_Actions (Def_Id, Predef_List);
-- Populate the two auxiliary tables used for dispatching -- 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. -- types that implement a limited interface.
if Ada_Version >= Ada_05 if Ada_Version >= Ada_05
and then not Is_Interface (Def_Id) and then Is_Concurrent_Record_Type (Def_Id)
and then not Is_Abstract (Def_Id) and then Implements_Interface (
and then not Is_Controlled (Def_Id) Typ => Def_Id,
and then Kind => Any_Limited_Interface,
Implements_Interface Check_Parent => True)
(Typ => Def_Id,
Kind => Any_Limited_Interface,
Check_Parent => True)
then then
Append_Freeze_Actions (Def_Id, Append_Freeze_Actions (Def_Id,
Make_Select_Specific_Data_Table (Def_Id)); Make_Select_Specific_Data_Table (Def_Id));
...@@ -5950,26 +5957,25 @@ package body Exp_Ch3 is ...@@ -5950,26 +5957,25 @@ package body Exp_Ch3 is
end if; end if;
-- Generate the declarations for the following primitive operations: -- Generate the declarations for the following primitive operations:
-- disp_asynchronous_select -- disp_asynchronous_select
-- disp_conditional_select -- disp_conditional_select
-- disp_get_prim_op_kind -- disp_get_prim_op_kind
-- disp_get_task_id -- disp_get_task_id
-- disp_timed_select -- 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 if Ada_Version >= Ada_05
and then and then
((Is_Interface (Tag_Typ) ((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ))
and then Is_Limited_Record (Tag_Typ)) or else
or else (Is_Concurrent_Record_Type (Tag_Typ)
(not Is_Abstract (Tag_Typ) and then Implements_Interface (
and then not Is_Controlled (Tag_Typ) Typ => Tag_Typ,
and then Kind => Any_Limited_Interface,
Implements_Interface Check_Parent => True)))
(Typ => Tag_Typ,
Kind => Any_Limited_Interface,
Check_Parent => True)))
then then
Append_To (Res, Append_To (Res,
Make_Subprogram_Declaration (Loc, Make_Subprogram_Declaration (Loc,
...@@ -6360,20 +6366,18 @@ package body Exp_Ch3 is ...@@ -6360,20 +6366,18 @@ package body Exp_Ch3 is
-- disp_get_task_id -- disp_get_task_id
-- disp_timed_select -- disp_timed_select
-- for limited interfaces and tagged types that implement a limited -- for limited interfaces and synchronized types that implement a
-- interface. The interface versions will have null bodies. -- limited interface. The interface versions will have null bodies.
if Ada_Version >= Ada_05 if Ada_Version >= Ada_05
and then and then
((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ)) ((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ))
or else or else
(not Is_Abstract (Tag_Typ) (Is_Concurrent_Record_Type (Tag_Typ)
and then not Is_Controlled (Tag_Typ) and then Implements_Interface (
and then Typ => Tag_Typ,
Implements_Interface Kind => Any_Limited_Interface,
(Typ => Tag_Typ, Check_Parent => True)))
Kind => Any_Limited_Interface,
Check_Parent => True)))
then then
Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ)); Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ)); Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ));
......
...@@ -4289,8 +4289,7 @@ package body Exp_Ch6 is ...@@ -4289,8 +4289,7 @@ package body Exp_Ch6 is
Expand_Interface_Thunk Expand_Interface_Thunk
(N => Prim, (N => Prim,
Thunk_Alias => Alias (Prim), Thunk_Alias => Alias (Prim),
Thunk_Id => Thunk_Id, Thunk_Id => Thunk_Id);
Thunk_Tag => Iface_Tag);
Insert_After (N, New_Thunk); Insert_After (N, New_Thunk);
...@@ -4341,8 +4340,7 @@ package body Exp_Ch6 is ...@@ -4341,8 +4340,7 @@ package body Exp_Ch6 is
Expand_Interface_Thunk Expand_Interface_Thunk
(N => Ancestor_Iface_Prim, (N => Ancestor_Iface_Prim,
Thunk_Alias => Prim_Op, Thunk_Alias => Prim_Op,
Thunk_Id => Thunk_Id, Thunk_Id => Thunk_Id);
Thunk_Tag => Iface_Tag);
Insert_After (N, New_Thunk); Insert_After (N, New_Thunk);
...@@ -4401,8 +4399,7 @@ package body Exp_Ch6 is ...@@ -4401,8 +4399,7 @@ package body Exp_Ch6 is
Expand_Interface_Thunk Expand_Interface_Thunk
(N => Prim, (N => Prim,
Thunk_Alias => Prim, Thunk_Alias => Prim,
Thunk_Id => Thunk_Id, Thunk_Id => Thunk_Id);
Thunk_Tag => Iface_Tag);
Insert_After (N, New_Thunk); Insert_After (N, New_Thunk);
Insert_After (New_Thunk, Insert_After (New_Thunk,
......
...@@ -184,11 +184,11 @@ package Exp_Disp is ...@@ -184,11 +184,11 @@ package Exp_Disp is
Get_Access_Level, Get_Access_Level,
Get_Entry_Index, Get_Entry_Index,
Get_External_Tag, Get_External_Tag,
Get_Offset_Index,
Get_Prim_Op_Address, Get_Prim_Op_Address,
Get_Prim_Op_Kind, Get_Prim_Op_Kind,
Get_RC_Offset, Get_RC_Offset,
Get_Remotely_Callable, Get_Remotely_Callable,
Get_Tagged_Kind,
Inherit_DT, Inherit_DT,
Inherit_TSD, Inherit_TSD,
Register_Interface_Tag, Register_Interface_Tag,
...@@ -197,6 +197,7 @@ package Exp_Disp is ...@@ -197,6 +197,7 @@ package Exp_Disp is
Set_Entry_Index, Set_Entry_Index,
Set_Expanded_Name, Set_Expanded_Name,
Set_External_Tag, Set_External_Tag,
Set_Interface_Table,
Set_Offset_Index, Set_Offset_Index,
Set_OSD, Set_OSD,
Set_Prim_Op_Address, Set_Prim_Op_Address,
...@@ -205,6 +206,7 @@ package Exp_Disp is ...@@ -205,6 +206,7 @@ package Exp_Disp is
Set_Remotely_Callable, Set_Remotely_Callable,
Set_SSD, Set_SSD,
Set_TSD, Set_TSD,
Set_Tagged_Kind,
TSD_Entry_Size, TSD_Entry_Size,
TSD_Prologue_Size); TSD_Prologue_Size);
...@@ -217,16 +219,17 @@ package Exp_Disp is ...@@ -217,16 +219,17 @@ package Exp_Disp is
-- Ada 2005 (AI-251): Displace all the actuals corresponding to class-wide -- Ada 2005 (AI-251): Displace all the actuals corresponding to class-wide
-- interfaces to reference the interface tag of the actual object -- 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 -- 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 -- the object to give access to the interface tag associated with the
-- secondary dispatch table -- secondary dispatch table.
function Expand_Interface_Thunk function Expand_Interface_Thunk
(N : Node_Id; (N : Node_Id;
Thunk_Alias : Node_Id; Thunk_Alias : Node_Id;
Thunk_Id : Entity_Id; Thunk_Id : Entity_Id) return Node_Id;
Thunk_Tag : Entity_Id) return Node_Id;
-- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
-- generate additional subprograms (thunks) to have a layout compatible -- generate additional subprograms (thunks) to have a layout compatible
-- with the C++ ABI. The thunk modifies the value of the first actual of -- with the C++ ABI. The thunk modifies the value of the first actual of
......
------------------------------------------------------------------------------
-- --
-- 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;
------------------------------------------------------------------------------
-- --
-- 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;
...@@ -120,6 +120,7 @@ package Rtsfind is ...@@ -120,6 +120,7 @@ package Rtsfind is
Ada_Streams, Ada_Streams,
Ada_Tags, Ada_Tags,
Ada_Task_Identification, Ada_Task_Identification,
Ada_Task_Termination,
-- Children of Ada.Calendar -- Children of Ada.Calendar
...@@ -488,10 +489,12 @@ package Rtsfind is ...@@ -488,10 +489,12 @@ package Rtsfind is
RE_Stream_Access, -- Ada.Streams.Stream_IO RE_Stream_Access, -- Ada.Streams.Stream_IO
RE_Abstract_Interface, -- Ada.Tags
RE_Addr_Ptr, -- Ada.Tags RE_Addr_Ptr, -- Ada.Tags
RE_Address_Array, -- Ada.Tags
RE_CW_Membership, -- Ada.Tags RE_CW_Membership, -- Ada.Tags
RE_IW_Membership, -- Ada.Tags
RE_Descendant_Tag, -- Ada.Tags RE_Descendant_Tag, -- Ada.Tags
RE_Displace, -- Ada.Tags
RE_DT_Entry_Size, -- Ada.Tags RE_DT_Entry_Size, -- Ada.Tags
RE_DT_Prologue_Size, -- Ada.Tags RE_DT_Prologue_Size, -- Ada.Tags
RE_External_Tag, -- Ada.Tags RE_External_Tag, -- Ada.Tags
...@@ -503,11 +506,16 @@ package Rtsfind is ...@@ -503,11 +506,16 @@ package Rtsfind is
RE_Get_Prim_Op_Kind, -- Ada.Tags RE_Get_Prim_Op_Kind, -- Ada.Tags
RE_Get_RC_Offset, -- Ada.Tags RE_Get_RC_Offset, -- Ada.Tags
RE_Get_Remotely_Callable, -- Ada.Tags RE_Get_Remotely_Callable, -- Ada.Tags
RE_Get_Tagged_Kind, -- Ada.Tags
RE_Inherit_DT, -- Ada.Tags RE_Inherit_DT, -- Ada.Tags
RE_Inherit_TSD, -- Ada.Tags RE_Inherit_TSD, -- Ada.Tags
RE_Interface_Data, -- Ada.Tags
RE_Interface_Tag, -- Ada.Tags
RE_Internal_Tag, -- Ada.Tags RE_Internal_Tag, -- Ada.Tags
RE_Is_Descendant_At_Same_Level, -- Ada.Tags RE_Is_Descendant_At_Same_Level, -- Ada.Tags
RE_IW_Membership, -- Ada.Tags
RE_Object_Specific_Data, -- Ada.Tags RE_Object_Specific_Data, -- Ada.Tags
RE_Offset_To_Top, -- Ada.Tags
RE_POK_Function, -- Ada.Tags RE_POK_Function, -- Ada.Tags
RE_POK_Procedure, -- Ada.Tags RE_POK_Procedure, -- Ada.Tags
RE_POK_Protected_Entry, -- Ada.Tags RE_POK_Protected_Entry, -- Ada.Tags
...@@ -517,13 +525,16 @@ package Rtsfind is ...@@ -517,13 +525,16 @@ package Rtsfind is
RE_POK_Task_Function, -- Ada.Tags RE_POK_Task_Function, -- Ada.Tags
RE_POK_Task_Procedure, -- Ada.Tags RE_POK_Task_Procedure, -- Ada.Tags
RE_Prim_Op_Kind, -- Ada.Tags RE_Prim_Op_Kind, -- Ada.Tags
RE_Primary_DT, -- Ada.Tags
RE_Register_Interface_Tag, -- Ada.Tags RE_Register_Interface_Tag, -- Ada.Tags
RE_Register_Tag, -- Ada.Tags RE_Register_Tag, -- Ada.Tags
RE_Secondary_DT, -- Ada.Tags
RE_Select_Specific_Data, -- Ada.Tags RE_Select_Specific_Data, -- Ada.Tags
RE_Set_Access_Level, -- Ada.Tags RE_Set_Access_Level, -- Ada.Tags
RE_Set_Entry_Index, -- Ada.Tags RE_Set_Entry_Index, -- Ada.Tags
RE_Set_Expanded_Name, -- Ada.Tags RE_Set_Expanded_Name, -- Ada.Tags
RE_Set_External_Tag, -- Ada.Tags RE_Set_External_Tag, -- Ada.Tags
RE_Set_Interface_Table, -- Ada.Tags
RE_Set_Num_Prim_Ops, -- Ada.Tags RE_Set_Num_Prim_Ops, -- Ada.Tags
RE_Set_Offset_Index, -- Ada.Tags RE_Set_Offset_Index, -- Ada.Tags
RE_Set_Offset_To_Top, -- Ada.Tags RE_Set_Offset_To_Top, -- Ada.Tags
...@@ -533,17 +544,20 @@ package Rtsfind is ...@@ -533,17 +544,20 @@ package Rtsfind is
RE_Set_RC_Offset, -- Ada.Tags RE_Set_RC_Offset, -- Ada.Tags
RE_Set_Remotely_Callable, -- Ada.Tags RE_Set_Remotely_Callable, -- Ada.Tags
RE_Set_SSD, -- Ada.Tags RE_Set_SSD, -- Ada.Tags
RE_Set_Tagged_Kind, -- Ada.Tags
RE_Set_TSD, -- Ada.Tags RE_Set_TSD, -- Ada.Tags
RE_Tag, -- Ada.Tags
RE_Tag_Error, -- Ada.Tags RE_Tag_Error, -- Ada.Tags
RE_Tagged_Kind, -- Ada.Tags
RE_TSD_Entry_Size, -- Ada.Tags RE_TSD_Entry_Size, -- Ada.Tags
RE_TSD_Prologue_Size, -- Ada.Tags RE_TSD_Prologue_Size, -- Ada.Tags
RE_Interface_Tag, -- Ada.Tags RE_TK_Abstract_Limited_Tagged, -- Ada.Tags
RE_Tag, -- Ada.Tags RE_TK_Abstract_Tagged, -- Ada.Tags
RE_Address_Array, -- 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_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_Abort_Task, -- Ada.Task_Identification
RE_Current_Task, -- Ada.Task_Identification RE_Current_Task, -- Ada.Task_Identification
...@@ -1629,10 +1643,12 @@ package Rtsfind is ...@@ -1629,10 +1643,12 @@ package Rtsfind is
RE_Stream_Access => Ada_Streams_Stream_IO, RE_Stream_Access => Ada_Streams_Stream_IO,
RE_Abstract_Interface => Ada_Tags,
RE_Addr_Ptr => Ada_Tags, RE_Addr_Ptr => Ada_Tags,
RE_Address_Array => Ada_Tags,
RE_CW_Membership => Ada_Tags, RE_CW_Membership => Ada_Tags,
RE_IW_Membership => Ada_Tags,
RE_Descendant_Tag => Ada_Tags, RE_Descendant_Tag => Ada_Tags,
RE_Displace => Ada_Tags,
RE_DT_Entry_Size => Ada_Tags, RE_DT_Entry_Size => Ada_Tags,
RE_DT_Prologue_Size => Ada_Tags, RE_DT_Prologue_Size => Ada_Tags,
RE_External_Tag => Ada_Tags, RE_External_Tag => Ada_Tags,
...@@ -1644,11 +1660,16 @@ package Rtsfind is ...@@ -1644,11 +1660,16 @@ package Rtsfind is
RE_Get_Prim_Op_Kind => Ada_Tags, RE_Get_Prim_Op_Kind => Ada_Tags,
RE_Get_RC_Offset => Ada_Tags, RE_Get_RC_Offset => Ada_Tags,
RE_Get_Remotely_Callable => Ada_Tags, RE_Get_Remotely_Callable => Ada_Tags,
RE_Get_Tagged_Kind => Ada_Tags,
RE_Inherit_DT => Ada_Tags, RE_Inherit_DT => Ada_Tags,
RE_Inherit_TSD => Ada_Tags, RE_Inherit_TSD => Ada_Tags,
RE_Interface_Data => Ada_Tags,
RE_Interface_Tag => Ada_Tags,
RE_Internal_Tag => Ada_Tags, RE_Internal_Tag => Ada_Tags,
RE_Is_Descendant_At_Same_Level => Ada_Tags, RE_Is_Descendant_At_Same_Level => Ada_Tags,
RE_IW_Membership => Ada_Tags,
RE_Object_Specific_Data => Ada_Tags, RE_Object_Specific_Data => Ada_Tags,
RE_Offset_To_Top => Ada_Tags,
RE_POK_Function => Ada_Tags, RE_POK_Function => Ada_Tags,
RE_POK_Procedure => Ada_Tags, RE_POK_Procedure => Ada_Tags,
RE_POK_Protected_Entry => Ada_Tags, RE_POK_Protected_Entry => Ada_Tags,
...@@ -1658,13 +1679,16 @@ package Rtsfind is ...@@ -1658,13 +1679,16 @@ package Rtsfind is
RE_POK_Task_Function => Ada_Tags, RE_POK_Task_Function => Ada_Tags,
RE_POK_Task_Procedure => Ada_Tags, RE_POK_Task_Procedure => Ada_Tags,
RE_Prim_Op_Kind => Ada_Tags, RE_Prim_Op_Kind => Ada_Tags,
RE_Primary_DT => Ada_Tags,
RE_Register_Interface_Tag => Ada_Tags, RE_Register_Interface_Tag => Ada_Tags,
RE_Register_Tag => Ada_Tags, RE_Register_Tag => Ada_Tags,
RE_Secondary_DT => Ada_Tags,
RE_Select_Specific_Data => Ada_Tags, RE_Select_Specific_Data => Ada_Tags,
RE_Set_Access_Level => Ada_Tags, RE_Set_Access_Level => Ada_Tags,
RE_Set_Entry_Index => Ada_Tags, RE_Set_Entry_Index => Ada_Tags,
RE_Set_Expanded_Name => Ada_Tags, RE_Set_Expanded_Name => Ada_Tags,
RE_Set_External_Tag => Ada_Tags, RE_Set_External_Tag => Ada_Tags,
RE_Set_Interface_Table => Ada_Tags,
RE_Set_Num_Prim_Ops => Ada_Tags, RE_Set_Num_Prim_Ops => Ada_Tags,
RE_Set_Offset_Index => Ada_Tags, RE_Set_Offset_Index => Ada_Tags,
RE_Set_Offset_To_Top => Ada_Tags, RE_Set_Offset_To_Top => Ada_Tags,
...@@ -1674,17 +1698,20 @@ package Rtsfind is ...@@ -1674,17 +1698,20 @@ package Rtsfind is
RE_Set_RC_Offset => Ada_Tags, RE_Set_RC_Offset => Ada_Tags,
RE_Set_Remotely_Callable => Ada_Tags, RE_Set_Remotely_Callable => Ada_Tags,
RE_Set_SSD => Ada_Tags, RE_Set_SSD => Ada_Tags,
RE_Set_Tagged_Kind => Ada_Tags,
RE_Set_TSD => Ada_Tags, RE_Set_TSD => Ada_Tags,
RE_Tag => Ada_Tags,
RE_Tag_Error => Ada_Tags, RE_Tag_Error => Ada_Tags,
RE_Tagged_Kind => Ada_Tags,
RE_TSD_Entry_Size => Ada_Tags, RE_TSD_Entry_Size => Ada_Tags,
RE_TSD_Prologue_Size => Ada_Tags, RE_TSD_Prologue_Size => Ada_Tags,
RE_Interface_Tag => Ada_Tags, RE_TK_Abstract_Limited_Tagged => Ada_Tags,
RE_Tag => Ada_Tags, RE_TK_Abstract_Tagged => Ada_Tags,
RE_Address_Array => 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_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_Abort_Task => Ada_Task_Identification,
RE_Current_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