diff options
author | Hristian Kirtchev <kirtchev@adacore.com> | 2005-11-15 14:54:36 +0100 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2005-11-15 14:54:36 +0100 |
commit | f4d379b8df138d05368dded1c6368ef549d65088 (patch) | |
tree | 873996443f0c7e7119eead6a25a380b1d3b5441a /gcc/ada/a-tags.ads | |
parent | 748d8778ede2249ee70323886d36fcdd5c08248d (diff) | |
download | gcc-f4d379b8df138d05368dded1c6368ef549d65088.zip gcc-f4d379b8df138d05368dded1c6368ef549d65088.tar.gz gcc-f4d379b8df138d05368dded1c6368ef549d65088.tar.bz2 |
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
Diffstat (limited to 'gcc/ada/a-tags.ads')
-rw-r--r-- | gcc/ada/a-tags.ads | 204 |
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; |