exp_ch3.adb (Component_Needs_Simple_Initialization): Add check for availability of RE_Interface_Tag.

2006-02-13  Javier Miranda  <miranda@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* exp_ch3.adb (Component_Needs_Simple_Initialization): Add check for
	availability of RE_Interface_Tag.
	(Build_Initialization_Call): Fix wrong access to the discriminant value.
	(Freeze_Record_Type): Do not generate the tables associated with
	timed and conditional dispatching calls through synchronized
	interfaces if compiling under No_Dispatching_Calls restriction.
	When compiling for Ada 2005, for a nonabstract
	type with a null extension, call Make_Controlling_Function_Wrappers
	and insert the wrapper function declarations and bodies (the latter
	being appended as freeze actions).
	(Predefined_Primitive_Bodies): Do not generate the bodies of the
	predefined primitives associated with timed and conditional
	dispatching calls through synchronized interfaces if we are
	compiling under No_Dispatching_Calls.
	(Build_Init_Procedure):  Use RTE_Available to check if a run-time
	service is available before generating a call.
	(Make_Controlling_Function_Wrappers): New procedure.
	(Expand_N_Full_Type_Declaration): Create a class-wide master for
	access-to-limited-interfaces because they can be used to reference
	tasks that implement such limited interface.
	(Build_Offset_To_Top_Functions): Build the tree corresponding to the
	procedure spec and body of the Offset_To_Top function that is generated
	when the parent of a type with discriminants has secondary dispatch
	tables.
	(Init_Secondary_Tags): Handle the case in which the parent of the type
	containing secondary dispatch tables has discriminants to generate the
	correct arguments to call Set_Offset_To_Top.
	(Build_Record_Init_Proc): Add call to Build_Offset_To_Top_Functions.

	* a-tags.ads, a-tags.adb: (Check_Index): Removed.
	Add Wide_[Wide_]Expanded_Name.
	(Get_Predefined_Prim_Op_Address): New subprogram that provides exactly
	the same functionality of Get_Prim_Op_Address but applied to predefined
	primitive operations because the pointers to the predefined primitives
	are now saved in a separate table.
	(Parent_Size): Modified to get access to the separate table of primitive
	operations or the parent type.
	(Set_Predefined_Prim_Op_Address): New subprogram that provides the same
	functionality of Set_Prim_Op_Address but applied to predefined primitive
	operations.
	(Set_Signature): New subprogram used to store the signature of a DT.
	(Displace): If the Offset_To_Top value is not static then call the
	function generated by the expander to get such value; otherwise use
	the value stored in the table of interfaces.
	(Offset_To_Top): The type of the actual has been changed to Address to
	give the correct support to tagged types with discriminants. In this
	case this value is stored just immediately after the tag field.
	(Set_Offset_To_Top): Two new formals have been added to indicate if the
	offset_to_top value is static and hence pass this value to the run-time
	to store it in the table of interfaces, or else if this value is dynamic
	and then pass to the run-time the address of a function that is
	generated by the expander to provide this value for each object of the
	type.

	* rtsfind.ads (Default_Prin_Op_Count): Removed.
	(Default_Prim_Op_Count): New entity
	(Get_Predefined_Prim_Op_Address): New entity
	(Set_Predefined_Prim_Op_Address): New entity
	(RE_Set_Signature): New entity

From-SVN: r111059

1 files changed, 86 insertions, 34 deletions

diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads
index 25fed4f..bb69544 100644
--- a/gcc/ada/a-tags.ads
+++ b/gcc/ada/a-tags.ads
@@ -68,6 +68,12 @@ package Ada.Tags is
 
    Tag_Error : exception;
 
+   function Wide_Expanded_Name (T : Tag) return Wide_String;
+   pragma Ada_05 (Wide_Expanded_Name);
+
+   function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String;
+   pragma Ada_05 (Wide_Wide_Expanded_Name);
+
 private
    --  The following subprogram specifications are placed here instead of
    --  the package body to see them from the frontend through rtsfind.
@@ -151,11 +157,25 @@ private
 
    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
-   --  used for dispatching asynchronous, conditional and timed selects. In
-   --  order to be space efficient, indexing is performed by subtracting this
-   --  constant value from the provided position in the auxiliary tables (must
-   --  match Exp_Disp.Default_Prim_Op_Count).
+   --  tagged type (must match Exp_Disp.Default_Prim_Op_Count).
+
+   type Signature_Kind is
+      (Unknown,
+       Valid_Signature,
+       Primary_DT,
+       Secondary_DT,
+       Abstract_Interface);
+   for Signature_Kind'Size use 8;
+   --  Kind of signature found in the header of the dispatch table. These
+   --  signatures are generated by the frontend and are used by the Check_XXX
+   --  routines to ensure that the kind of dispatch table managed by each of
+   --  the routines in this package is correct. This additional check is only
+   --  performed with this run-time package is compiled with assertions enabled
+
+   --  The signature is a sequence of two bytes. The first byte must have the
+   --  value Valid_Signature, and the second byte must have a value in the
+   --  range Primary_DT .. Abstract_Interface. The Unknown value is used by
+   --  the Check_XXX routines to indicate that the signature is wrong.
 
    package SSE renames System.Storage_Elements;
 
@@ -200,6 +220,13 @@ private
    --  operation in the DT, retrieve the corresponding operation's position in
    --  the primary dispatch table from the Offset Specific Data table of T.
 
+   function Get_Predefined_Prim_Op_Address
+     (T        : Tag;
+      Position : Positive) return System.Address;
+   --  Given a pointer to a dispatch table (T) and a position in the DT
+   --  this function returns the address of the virtual function stored
+   --  in it (used for dispatching calls).
+
    function Get_Prim_Op_Address
      (T        : Tag;
       Position : Positive) return System.Address;
@@ -239,9 +266,11 @@ private
    --  Initialize the TSD of a type knowing the tag of the direct ancestor
 
    function Offset_To_Top
-     (T : Tag) return System.Storage_Elements.Storage_Offset;
+     (This : System.Address) return System.Storage_Elements.Storage_Offset;
    --  Returns the current value of the offset_to_top component available in
-   --  the prologue of the dispatch table.
+   --  the prologue of the dispatch table. If the parent of the tagged type
+   --  has discriminants this value is stored in a record component just
+   --  immediately after the tag component.
 
    function OSD (T : Tag) return Object_Specific_Data_Ptr;
    --  Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table,
@@ -305,7 +334,9 @@ private
    procedure Set_Offset_To_Top
      (This         : System.Address;
       Interface_T  : Tag;
-      Offset_Value : System.Storage_Elements.Storage_Offset);
+      Is_Static    : Boolean;
+      Offset_Value : System.Storage_Elements.Storage_Offset;
+      Offset_Func  : System.Address);
    --  Ada 2005 (AI-251): Initialize the Offset_To_Top field in the prologue of
    --  the dispatch table. In primary dispatch tables the value of "This" is
    --  not required (and the compiler passes always the Null_Address value) and
@@ -319,6 +350,14 @@ private
    --  Given a pointer T to a secondary dispatch table, store the pointer to
    --  the record containing the Object Specific Data generated by GNAT.
 
+   procedure Set_Predefined_Prim_Op_Address
+     (T        : Tag;
+      Position : Positive;
+      Value    : System.Address);
+   --  Given a pointer to a dispatch Table (T) and a position in the dispatch
+   --  table associated with a predefined primitive operation, put the address
+   --  of the virtual function in it (used for overriding).
+
    procedure Set_Prim_Op_Address
      (T        : Tag;
       Position : Positive;
@@ -342,6 +381,9 @@ private
    --  Set to true if the type has been declared in a context described
    --  in E.4 (18).
 
+   procedure Set_Signature (T : Tag; Value : Signature_Kind);
+   --  Given a pointer T to a dispatch table, store the signature id
+
    procedure Set_SSD (T : Tag; Value : System.Address);
    --  Given a pointer T to a dispatch Table, stores the pointer to the record
    --  containing the Select Specific Data generated by GNAT.
@@ -363,11 +405,15 @@ private
    --  record containing the Type Specific Data generated by GNAT.
 
    DT_Prologue_Size : constant SSE.Storage_Count :=
-     SSE.Storage_Count (4 * (Standard'Address_Size / System.Storage_Unit));
-   --  Size of the first part of the dispatch table
+                        SSE.Storage_Count
+                          ((Default_Prim_Op_Count + 4) *
+                            (Standard'Address_Size / System.Storage_Unit));
+   --  Size of the hidden part of the dispatch table. It contains the table of
+   --  predefined primitive operations plus the C++ ABI header.
 
    DT_Signature_Size : constant SSE.Storage_Count :=
-     SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
+                         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 :=
@@ -375,23 +421,35 @@ private
    --  Size of the Tagged_Type_Kind field of the dispatch table
 
    DT_Offset_To_Top_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 the Offset_To_Top field of the Dispatch Table
 
    DT_Typeinfo_Ptr_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 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
 
+   Tag_Size : constant SSE.Storage_Count :=
+     SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
+   --  Size of each tag
+
    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 :=
-     SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
+                      SSE.Storage_Count
+                        (1 * (Standard'Address_Size / System.Storage_Unit));
    --  Size of each ancestor tag entry in the TSD
 
    type Address_Array is array (Natural range <>) of System.Address;
@@ -400,24 +458,6 @@ private
    --  of this type are declared with a dummy size of 1, the actual size
    --  depending on the number of primitive operations.
 
-   type Signature_Kind is
-      (Unknown,
-       Valid_Signature,
-       Primary_DT,
-       Secondary_DT,
-       Abstract_Interface);
-   for Signature_Kind'Size use 8;
-   --  Kind of signature found in the header of the dispatch table. These
-   --  signatures are generated by the frontend and are used by the Check_XXX
-   --  routines to ensure that the kind of dispatch table managed by each of
-   --  the routines in this package is correct. This additional check is only
-   --  performed with this run-time package is compiled with assertions enabled
-
-   --  The signature is a sequence of two bytes. The first byte must have the
-   --  value Valid_Signature, and the second byte must have a value in the
-   --  range Primary_DT .. Abstract_Interface. The Unknown value is used by
-   --  the Check_XXX routines to indicate that the signature is wrong.
-
    --  Unchecked Conversions
 
    type Addr_Ptr is access System.Address;
@@ -427,6 +467,8 @@ private
       array (1 .. DT_Signature_Size) of Signature_Kind;
    --  Type used to see the signature as a sequence of Signature_Kind values
 
+   type Signature_Values_Ptr is access all Signature_Values;
+
    function To_Addr_Ptr is
       new Unchecked_Conversion (System.Address, Addr_Ptr);
 
@@ -455,6 +497,13 @@ private
      new Unchecked_Conversion (System.Storage_Elements.Storage_Offset,
                                Signature_Values);
 
+   function To_Signature_Values_Ptr is
+     new Unchecked_Conversion (System.Address,
+                               Signature_Values_Ptr);
+
+   function To_Tag is
+     new Unchecked_Conversion (System.Address, Tag);
+
    function To_Tag_Ptr is
      new Unchecked_Conversion (System.Address, Tag_Ptr);
 
@@ -470,6 +519,7 @@ private
    pragma Inline_Always (Get_Access_Level);
    pragma Inline_Always (Get_Entry_Index);
    pragma Inline_Always (Get_Offset_Index);
+   pragma Inline_Always (Get_Predefined_Prim_Op_Address);
    pragma Inline_Always (Get_Prim_Op_Address);
    pragma Inline_Always (Get_Prim_Op_Kind);
    pragma Inline_Always (Get_RC_Offset);
@@ -488,10 +538,12 @@ private
    pragma Inline_Always (Set_Num_Prim_Ops);
    pragma Inline_Always (Set_Offset_Index);
    pragma Inline_Always (Set_Offset_To_Top);
+   pragma Inline_Always (Set_Predefined_Prim_Op_Address);
    pragma Inline_Always (Set_Prim_Op_Address);
    pragma Inline_Always (Set_Prim_Op_Kind);
    pragma Inline_Always (Set_RC_Offset);
    pragma Inline_Always (Set_Remotely_Callable);
+   pragma Inline_Always (Set_Signature);
    pragma Inline_Always (Set_OSD);
    pragma Inline_Always (Set_SSD);
    pragma Inline_Always (Set_TSD);