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.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@108284 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 220 insertions, 0 deletions

diff --git a/gcc/ada/exp_sel.adb b/gcc/ada/exp_sel.adb
new file mode 100644
index 00000000000..dbb7fb29086
--- /dev/null
+++ b/gcc/ada/exp_sel.adb
@@ -0,0 +1,220 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         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;