rtsfind.ads, [...]: Complete support for Ada 2005 interfaces.

2005-11-14  Hristian Kirtchev  <kirtchev@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* rtsfind.ads, exp_util.adb, exp_util.ads, exp_disp.adb, exp_disp.ads,
	exp_ch7.adb, sem_ch9.adb, snames.adb, snames.ads,
	exp_ch9.adb, exp_ch9.ads, exp_ch6.adb, exp_ch3.adb, exp_ch3.ads,
	einfo.ads, einfo.adb: Complete support for Ada 2005 interfaces.

	* a-tags.ads, a-tags.adb: Major rewrite and additions to implement
	properly new Ada 2005 interfaces (AI-345) and add run-time checks (via
	assertions).

	* exp_dbug.ads, exp_dbug.adb (Get_Secondary_DT_External_Name): New
	subprogram that generates the external name associated with a
	secondary dispatch table.
	(Get_Secondary_DT_External_Name): New subprogram that generates the
	external name associated with a secondary dispatch table.

From-SVN: r106965

1 files changed, 148 insertions, 56 deletions

diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads
index 34d7d63..46e6c20 100644
--- a/gcc/ada/a-tags.ads
+++ b/gcc/ada/a-tags.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
 --                                                                          --
 -- This specification is derived from the Ada Reference Manual for use with --
 -- GNAT. The copyright notice above, and the license provisions that follow --
@@ -53,31 +53,38 @@ package Ada.Tags is
 
    function Internal_Tag (External : String) return Tag;
 
-   function Descendant_Tag (External : String; Ancestor : Tag) return Tag;
+   function Descendant_Tag
+     (External : String;
+      Ancestor : Tag) return Tag;
+   pragma Ada_05 (Descendant_Tag);
 
    function Is_Descendant_At_Same_Level
      (Descendant : Tag;
       Ancestor   : Tag) return Boolean;
+   pragma Ada_05 (Is_Descendant_At_Same_Level);
 
    function Parent_Tag (T : Tag) return Tag;
+   pragma Ada_05 (Parent_Tag);
 
    Tag_Error : exception;
 
 private
+   --  The following subprogram specifications are placed here instead of
+   --  the package body to see them from the frontend through rtsfind.
 
    ---------------------------------------------------------------
    -- Abstract Procedural Interface For The GNAT Dispatch Table --
    ---------------------------------------------------------------
 
    --  GNAT's Dispatch Table format is customizable in order to match the
-   --  format used in another language. GNAT supports programs that use
-   --  two different dispatch table formats at the same time: the native
-   --  format that supports Ada 95 tagged types and which is described in
-   --  Ada.Tags, and a foreign format for types that are imported from some
-   --  other language (typically C++) which is described in Interfaces.CPP.
-   --  The runtime information kept for each tagged type is separated into
-   --  two objects: the Dispatch Table and the Type Specific Data record.
-   --  These two objects are allocated statically using the constants:
+   --  format used in another language. GNAT supports programs that use two
+   --  different dispatch table formats at the same time: the native format
+   --  that supports Ada 95 tagged types and which is described in Ada.Tags,
+   --  and a foreign format for types that are imported from some other
+   --  language (typically C++) which is described in Interfaces.CPP. The
+   --  runtime information kept for each tagged type is separated into two
+   --  objects: the Dispatch Table and the Type Specific Data record. These
+   --  two objects are allocated statically using the constants:
 
    --      DT Size  = DT_Prologue_Size  + Nb_Prim * DT_Entry_Size
    --      TSD Size = TSD_Prologue_Size + (1 + Idepth)  * TSD_Entry_Size
@@ -85,9 +92,9 @@ private
    --  where Nb_prim is the number of primitive operations of the given
    --  type and Idepth its inheritance depth.
 
-   --  The compiler generates calls to the following SET routines to
-   --  initialize those structures and uses the GET functions to
-   --  retreive the information when needed
+   --  In order to set or retrieve information from the Dispatch Table or
+   --  the Type Specific Data record, GNAT generates calls to Set_XXX or
+   --  Get_XXX routines, where XXX is the name of the field of interest.
 
    type Dispatch_Table;
    type Tag is access all Dispatch_Table;
@@ -95,6 +102,19 @@ private
 
    No_Tag : constant Tag := null;
 
+   type Object_Specific_Data (Nb_Prim : Positive);
+   type Object_Specific_Data_Ptr is access all Object_Specific_Data;
+   --  Information associated with the secondary dispatch table of tagged-type
+   --  objects implementing abstract interfaces.
+
+   type Select_Specific_Data (Nb_Prim : Positive);
+   type Select_Specific_Data_Ptr is access all Select_Specific_Data;
+   --  A table used to store the primitive operation kind and entry index of
+   --  primitive subprograms of a type that implements a limited interface.
+   --  The Select Specific Data table resides in the Type Specific Data of a
+   --  type. This construct is used in the handling of dispatching triggers
+   --  in select statements.
+
    type Type_Specific_Data;
    type Type_Specific_Data_Ptr is access all Type_Specific_Data;
 
@@ -109,17 +129,16 @@ private
       POK_Protected_Function,
       POK_Protected_Procedure,
       POK_Task_Entry,
+      POK_Task_Function,
       POK_Task_Procedure);
 
-   --  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 efficien, indexing is performed by
-   --  subtracting this constant value from the provided position in the
-   --  auxiliary tables.
-   --  This value is mirrored from Exp_Disp.ads.
-
-   Default_Prim_Op_Count : constant Positive := 14;
+   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).
 
    package SSE renames System.Storage_Elements;
 
@@ -127,9 +146,7 @@ private
    --  Given the tag of an object and the tag associated to a type, return
    --  true if Obj is in Typ'Class.
 
-   function IW_Membership
-     (This : System.Address;
-      T    : Tag) return Boolean;
+   function IW_Membership (This : System.Address; T : Tag) return Boolean;
    --  Ada 2005 (AI-251): General routine that checks if a given object
    --  implements a tagged type. Its common usage is to check if Obj is in
    --  Iface'Class, but it is also used to check if a class-wide interface
@@ -147,22 +164,27 @@ private
    --  Given the tag associated with a type, returns the accessibility level
    --  of the type.
 
-   function Get_Entry_Index
-     (T        : Tag;
-      Position : Positive) return Positive;
+   function Get_Entry_Index (T : Tag; Position : Positive) return Positive;
    --  Return a primitive operation's entry index (if entry) given a dispatch
    --  table T and a position of a primitive operation in T.
 
    function Get_External_Tag (T : Tag) return System.Address;
    --  Retrieve the address of a null terminated string containing
-   --  the external name
+   --  the external name.
+
+   function Get_Offset_Index
+     (T        : Interface_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
+   --  the primary dispatch table from the Offset Specific Data table of T.
 
    function Get_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)
+   --  in it (used for dispatching calls).
 
    function Get_Prim_Op_Kind
      (T        : Tag;
@@ -182,10 +204,7 @@ private
    function Get_Remotely_Callable (T : Tag) return Boolean;
    --  Return the value previously set by Set_Remotely_Callable
 
-   procedure Inherit_DT
-    (Old_T       : Tag;
-     New_T       : Tag;
-     Entry_Count : Natural);
+   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
    --  inherited (Entry_Count).
@@ -193,21 +212,23 @@ 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;
+   --  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.
+
    function Parent_Size
      (Obj : System.Address;
       T   : Tag) return SSE.Storage_Count;
-   --  Computes the size the ancestor part of a tagged extension object
-   --  whose address is 'obj' by calling the indirectly _size function of
-   --  the ancestor. The ancestor is the parent of the type represented by
-   --  tag T. This function assumes that _size is always in slot 1 of
-   --  the dispatch table.
+   --  Computes the size the ancestor part of a tagged extension object whose
+   --  address is 'obj' by calling indirectly the ancestor _size function. The
+   --  ancestor is the parent of the type represented by tag T. This function
+   --  assumes that _size is always in slot one of the dispatch table.
 
    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);
    --  Ada 2005 (AI-251): Used to initialize the table of interfaces
    --  implemented by a type. Required to give support to IW_Membership.
 
@@ -215,13 +236,21 @@ private
    --  Insert the Tag and its associated external_tag in a table for the
    --  sake of Internal_Tag
 
-   procedure Set_Entry_Index
-     (T        : Tag;
-      Position : Positive;
-      Value    : Positive);
+   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_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;
+      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);
@@ -230,6 +259,10 @@ private
    --  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);
+   --  Given a pointer T to a secondary dispatch table, store the pointer to
+   --  the record containing the Object Specific Data generated by GNAT.
+
    procedure Set_Prim_Op_Address
      (T        : Tag;
       Position : Positive;
@@ -245,6 +278,10 @@ 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.
@@ -269,15 +306,24 @@ private
    --  Set to true if the type has been declared in a context described
    --  in E.4 (18).
 
+   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.
+
    function TSD (T : Tag) return Type_Specific_Data_Ptr;
-   --  Given a pointer T to a dispatch Table, retreives the address of the
-   --  record containing the Type Specific Data generated by GNAT
+   --  Given a pointer T to a dispatch Table, retrieves the address of the
+   --  record containing the Type Specific Data generated by GNAT.
 
    DT_Prologue_Size : constant SSE.Storage_Count :=
                         SSE.Storage_Count
-                          (2 * (Standard'Address_Size / System.Storage_Unit));
+                          (3 * (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);
+   --  Size of the Signature field of the dispatch table
+
    DT_Offset_To_Top_Size : constant SSE.Storage_Count :=
                             SSE.Storage_Count
                               (Standard'Address_Size / System.Storage_Unit);
@@ -295,7 +341,7 @@ private
 
    TSD_Prologue_Size : constant SSE.Storage_Count :=
                          SSE.Storage_Count
-                           (8 * (Standard'Address_Size / System.Storage_Unit));
+                          (10 * (Standard'Address_Size / System.Storage_Unit));
    --  Size of the first part of the type specific data
 
    TSD_Entry_Size : constant SSE.Storage_Count :=
@@ -308,22 +354,57 @@ private
    --  of this type are declared with a dummy size of 1, the actual size
    --  depending on the number of primitive operations.
 
-   --  Unchecked Conversions for Tag and TSD
+   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;
+   type Tag_Ptr  is access Tag;
+
+   type Signature_Values is
+      array (1 .. DT_Signature_Size) of Signature_Kind;
+   --  Type used to see the signature as a sequence of Signature_Kind values
+
+   function To_Addr_Ptr is
+      new Unchecked_Conversion (System.Address, Addr_Ptr);
 
    function To_Type_Specific_Data_Ptr is
      new Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
 
    function To_Address is
-     new Unchecked_Conversion (Type_Specific_Data_Ptr, System.Address);
+     new Unchecked_Conversion (Interface_Tag, System.Address);
 
    function To_Address is
      new Unchecked_Conversion (Tag, System.Address);
 
-   type Addr_Ptr is access System.Address;
-   type Tag_Ptr  is access Tag;
+   function To_Address is
+     new Unchecked_Conversion (Type_Specific_Data_Ptr, System.Address);
 
-   function To_Addr_Ptr is
-      new Unchecked_Conversion (System.Address, Addr_Ptr);
+   function To_Object_Specific_Data_Ptr is
+     new Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr);
+
+   function To_Select_Specific_Data_Ptr is
+     new Unchecked_Conversion (System.Address, Select_Specific_Data_Ptr);
+
+   function To_Signature_Values is
+     new Unchecked_Conversion (System.Storage_Elements.Storage_Offset,
+                               Signature_Values);
 
    function To_Tag_Ptr is
      new Unchecked_Conversion (System.Address, Tag_Ptr);
@@ -334,21 +415,32 @@ private
    pragma Inline_Always (CW_Membership);
    pragma Inline_Always (IW_Membership);
    pragma Inline_Always (Get_Access_Level);
+   pragma Inline_Always (Get_Entry_Index);
+   pragma Inline_Always (Get_Offset_Index);
    pragma Inline_Always (Get_Prim_Op_Address);
+   pragma Inline_Always (Get_Prim_Op_Kind);
    pragma Inline_Always (Get_RC_Offset);
    pragma Inline_Always (Get_Remotely_Callable);
    pragma Inline_Always (Inherit_DT);
    pragma Inline_Always (Inherit_TSD);
+   pragma Inline_Always (OSD);
    pragma Inline_Always (Register_Interface_Tag);
    pragma Inline_Always (Register_Tag);
    pragma Inline_Always (Set_Access_Level);
+   pragma Inline_Always (Set_Entry_Index);
    pragma Inline_Always (Set_Expanded_Name);
    pragma Inline_Always (Set_External_Tag);
+   pragma Inline_Always (Set_Num_Prim_Ops);
+   pragma Inline_Always (Set_Offset_Index);
    pragma Inline_Always (Set_Offset_To_Top);
    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_OSD);
+   pragma Inline_Always (Set_SSD);
    pragma Inline_Always (Set_TSD);
+   pragma Inline_Always (SSD);
    pragma Inline_Always (TSD);
 
 end Ada.Tags;