package body Ada.Tags is
--- Structure of the GNAT Primary Dispatch Table
-
--- +----------------------+
--- | table of |
--- : predefined primitive :
--- | ops pointers |
--- +----------------------+
--- | Signature |
--- +----------------------+
--- | Tagged_Kind |
--- +----------------------+
--- | Offset_To_Top |
--- +----------------------+
--- | Typeinfo_Ptr/TSD_Ptr ---> Type Specific Data
--- Tag ---> +----------------------+ +-------------------+
--- | table of | | inheritance depth |
--- : primitive ops : +-------------------+
--- | pointers | | access level |
--- +----------------------+ +-------------------+
--- | expanded name |
--- +-------------------+
--- | external tag |
--- +-------------------+
--- | hash table link |
--- +-------------------+
--- | remotely callable |
--- +-------------------+
--- | rec ctrler offset |
--- +-------------------+
--- | num prim ops |
--- +-------------------+
--- | Ifaces_Table_Ptr --> Interface Data
--- +-------------------+ +------------+
--- Select Specific Data <---- SSD_Ptr | | table |
--- +--------------------+ +-------------------+ : of :
--- | table of primitive | | table of | | interfaces |
--- : operation : : ancestor : +------------+
--- | kinds | | tags |
--- +--------------------+ +-------------------+
--- | table of |
--- : entry :
--- | indices |
--- +--------------------+
-
--- Structure of the GNAT Secondary Dispatch Table
-
--- +-----------------------+
--- | table of |
--- : predefined primitive :
--- | ops pointers |
--- +-----------------------+
--- | Signature |
--- +-----------------------+
--- | Tagged_Kind |
--- +-----------------------+
--- | Offset_To_Top |
--- +-----------------------+
--- | OSD_Ptr |---> Object Specific Data
--- Tag ---> +-----------------------+ +---------------+
--- | table of | | num prim ops |
--- : primitive op : +---------------+
--- | thunk pointers | | table of |
--- +-----------------------+ + primitive |
--- | op offsets |
--- +---------------+
-
- ----------------------------------
- -- GNAT Dispatch Table Prologue --
- ----------------------------------
-
- -- GNAT's Dispatch Table prologue contains several fields which are hidden
- -- in order to preserve compatibility with C++. These fields are accessed
- -- by address calculations performed in the following manner:
-
- -- Field : Field_Type :=
- -- (To_Address (Tag) - Sum_Of_Preceding_Field_Sizes).all;
-
- -- The bracketed subtraction shifts the pointer (Tag) from the table of
- -- primitive operations (or thunks) to the field in question. Since the
- -- result of the subtraction is an address, dereferencing it will obtain
- -- the actual value of the field.
-
- -- Guidelines for addition of new hidden fields
-
- -- Define a Field_Type and Field_Type_Ptr (access to Field_Type) in
- -- A-Tags.ads for the newly introduced field.
-
- -- Defined the size of the new field as a constant Field_Name_Size
-
- -- Introduce an Unchecked_Conversion from System.Address to
- -- Field_Type_Ptr in A-Tags.ads.
-
- -- Define the specifications of Get_<Field_Name> and Set_<Field_Name>
- -- in a-tags.ads.
-
- -- Update the GNAT Dispatch Table structure in a-tags.adb
-
- -- Provide bodies to the Get_<Field_Name> and Set_<Field_Name> routines.
- -- The profile of a Get_<Field_Name> routine should resemble:
-
- -- function Get_<Field_Name> (T : Tag; ...) return Field_Type is
- -- Field : constant System.Address :=
- -- To_Address (T) - <Sum_Of_Previous_Field_Sizes>;
- -- begin
- -- pragma Assert (Check_Signature (T, <Applicable_DT>));
- -- <Additional_Assertions>
-
- -- return To_Field_Type_Ptr (Field).all;
- -- end Get_<Field_Name>;
-
- -- The profile of a Set_<Field_Name> routine should resemble:
-
- -- procedure Set_<Field_Name> (T : Tag; ..., Value : Field_Type) is
- -- Field : constant System.Address :=
- -- To_Address (T) - <Sum_Of_Previous_Field_Sizes>;
- -- begin
- -- pragma Assert (Check_Signature (T, <Applicable_DT>));
- -- <Additional_Assertions>
-
- -- To_Field_Type_Ptr (Field).all := Value;
- -- end Set_<Field_Name>;
-
- -- NOTE: For each field in the prologue which precedes the newly added
- -- one, find and update its respective Sum_Of_Previous_Field_Sizes by
- -- subtractind Field_Name_Size from it. Falure to do so will clobber the
- -- previous prologue field.
-
- K_Typeinfo : constant SSE.Storage_Count := DT_Typeinfo_Ptr_Size;
-
- K_Offset_To_Top : constant SSE.Storage_Count :=
- K_Typeinfo + DT_Offset_To_Top_Size;
-
- K_Tagged_Kind : constant SSE.Storage_Count :=
- K_Offset_To_Top + DT_Tagged_Kind_Size;
-
- K_Signature : constant SSE.Storage_Count :=
- K_Tagged_Kind + DT_Signature_Size;
-
- subtype Cstring is String (Positive);
- type Cstring_Ptr is access all Cstring;
-
- -- We suppress index checks because the declared size in the record below
- -- is a dummy size of one (see below).
-
- type Tag_Table is array (Natural range <>) of Tag;
- pragma Suppress_Initialization (Tag_Table);
- pragma Suppress (Index_Check, On => Tag_Table);
-
- -- Declarations for the table of interfaces
-
- type Interface_Data_Element is record
- Iface_Tag : Tag;
- Static_Offset_To_Top : Boolean;
- Offset_To_Top_Value : System.Storage_Elements.Storage_Offset;
- Offset_To_Top_Func : System.Address;
- end record;
- -- If some ancestor of the tagged type has discriminants the field
- -- Static_Offset_To_Top is False and the field Offset_To_Top_Func
- -- is used to store the address of the function generated by the
- -- expander which provides this value; otherwise Static_Offset_To_Top
- -- is True and such value is stored in the Offset_To_Top_Value field.
-
- type Interfaces_Array is
- array (Natural range <>) of Interface_Data_Element;
-
- type Interface_Data (Nb_Ifaces : Positive) is record
- Table : Interfaces_Array (1 .. Nb_Ifaces);
- end record;
-
- -- Object specific data types
+ -- Object specific data types (see description in a-tags.ads)
type Object_Specific_Data_Array is array (Positive range <>) of Positive;
type Object_Specific_Data (Nb_Prim : Positive) is record
- Num_Prim_Ops : Natural;
- -- Number of primitive operations of the dispatch table. This field is
- -- used by the run-time check routines that are activated when the
- -- run-time is compiled with assertions enabled.
-
OSD_Table : Object_Specific_Data_Array (1 .. Nb_Prim);
-- Table used in secondary DT to reference their counterpart in the
-- select specific data (in the TSD of the primary DT). This construct
-- NOTE: Nb_Prim is the number of non-predefined primitive operations
end record;
- -- Type specific data types
-
- type Type_Specific_Data is record
- Idepth : Natural;
- -- Inheritance Depth Level: Used to implement the membership test
- -- associated with single inheritance of tagged types in constant-time.
- -- In addition it also indicates the size of the first table stored in
- -- the Tags_Table component (see comment below).
-
- Access_Level : Natural;
- -- Accessibility level required to give support to Ada 2005 nested type
- -- extensions. This feature allows safe nested type extensions by
- -- shifting the accessibility checks to certain operations, rather than
- -- being enforced at the type declaration. In particular, by performing
- -- run-time accessibility checks on class-wide allocators, class-wide
- -- function return, and class-wide stream I/O, the danger of objects
- -- outliving their type declaration can be eliminated (Ada 2005: AI-344)
-
- Expanded_Name : Cstring_Ptr;
- External_Tag : Cstring_Ptr;
- HT_Link : Tag;
- -- Components used to give support to the Ada.Tags subprograms described
- -- in ARM 3.9
-
- Remotely_Callable : Boolean;
- -- Used to check ARM E.4 (18)
-
- RC_Offset : SSE.Storage_Offset;
- -- Controller Offset: Used to give support to tagged controlled objects
- -- (see Get_Deep_Controller at s-finimp)
-
- Ifaces_Table_Ptr : System.Address;
- -- Pointer to the table of interface tags. It is used to implement the
- -- membership test associated with interfaces and also for backward
- -- abstract interface type conversions (Ada 2005:AI-251)
-
- Num_Prim_Ops : Natural;
- -- Number of primitive operations of the dispatch table. This field is
- -- used for additional run-time checks when the run-time is compiled
- -- with assertions enabled.
-
- SSD_Ptr : System.Address;
- -- Pointer to a table of records used in dispatching selects. This
- -- field has a meaningful value for all tagged types that implement
- -- a limited, protected, synchronized or task interfaces and have
- -- non-predefined primitive operations.
-
- Tags_Table : Tag_Table (0 .. 1);
- -- The size of the Tags_Table array actually depends on the tagged type
- -- to which it applies. The compiler ensures that has enough space to
- -- store all the entries of the two tables phisically stored there: the
- -- "table of ancestor tags" and the "table of interface tags". For this
- -- purpose we are using the same mechanism as for the Prims_Ptr array in
- -- the Dispatch_Table record. See comments below on Prims_Ptr for
- -- further details.
- end record;
-
- type Dispatch_Table is record
-
- -- According to the C++ ABI the components Offset_To_Top and
- -- Typeinfo_Ptr are stored just "before" the dispatch table (that is,
- -- the Prims_Ptr table), and they are referenced with negative offsets
- -- referring to the base of the dispatch table. The _Tag (or the
- -- VTable_Ptr in C++ terminology) must point to the base of the virtual
- -- table, just after these components, to point to the Prims_Ptr table.
- -- For this purpose the expander generates a Prims_Ptr table that has
- -- enough space for these additional components, and generates code that
- -- displaces the _Tag to point after these components.
-
- -- Signature : Signature_Kind;
- -- Tagged_Kind : Tagged_Kind;
- -- Offset_To_Top : Natural;
- -- Typeinfo_Ptr : System.Address;
-
- Prims_Ptr : Address_Array (1 .. 1);
- -- The size of the Prims_Ptr array actually depends on the tagged type
- -- to which it applies. For each tagged type, the expander computes the
- -- actual array size, allocates the Dispatch_Table record accordingly,
- -- and generates code that displaces the base of the record after the
- -- Typeinfo_Ptr component. For this reason the first two components have
- -- been commented in the previous declaration. The access to these
- -- components is done by means of local functions.
- --
- -- To avoid the use of discriminants to define the actual size of the
- -- dispatch table, we used to declare the tag as a pointer to a record
- -- that contains an arbitrary array of addresses, using Positive as its
- -- index. This ensures that there are never range checks when accessing
- -- the dispatch table, but it prevents GDB from displaying tagged types
- -- properly. A better approach is to declare this record type as holding
- -- small number of addresses, and to explicitly suppress checks on it.
- --
- -- Note that in both cases, this type is never allocated, and serves
- -- only to declare the corresponding access type.
- end record;
-
- type Signature_Type is
- (Must_Be_Primary_DT,
- Must_Be_Secondary_DT,
- Must_Be_Primary_Or_Secondary_DT,
- Must_Be_Interface,
- Must_Be_Primary_Or_Interface);
- -- Type of signature accepted by primitives in this package that are called
- -- during the elaboration of tagged types. This type is used by the routine
- -- Check_Signature that is called only when the run-time is compiled with
- -- assertions enabled.
-
---------------------------------------------
-- Unchecked Conversions for String Fields --
---------------------------------------------
-- Local Subprograms --
-----------------------
- function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean;
- -- Check that the signature of T is valid and corresponds with the subset
- -- specified by the signature Kind.
-
- function Check_Size
- (Old_T : Tag;
- New_T : Tag;
- Entry_Count : Natural) return Boolean;
- -- Verify that Old_T and New_T have at least Entry_Count entries
-
- function Get_Num_Prim_Ops (T : Tag) return Natural;
- -- Retrieve the number of primitive operations in the dispatch table of T
-
function Is_Primary_DT (T : Tag) return Boolean;
pragma Inline_Always (Is_Primary_DT);
-- Given a tag returns True if it has the signature of a primary dispatch
end HTable_Subprograms;
- ---------------------
- -- Check_Signature --
- ---------------------
-
- function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean is
- Signature : constant Storage_Offset_Ptr :=
- To_Storage_Offset_Ptr (To_Address (T) - K_Signature);
-
- Sig_Values : constant Signature_Values :=
- To_Signature_Values (Signature.all);
-
- Signature_Id : Signature_Kind;
-
- begin
- if Sig_Values (1) /= Valid_Signature then
- Signature_Id := Unknown;
-
- elsif Sig_Values (2) in Primary_DT .. Abstract_Interface then
- Signature_Id := Sig_Values (2);
-
- else
- Signature_Id := Unknown;
- end if;
-
- case Signature_Id is
- when Primary_DT =>
- if Kind = Must_Be_Secondary_DT
- or else Kind = Must_Be_Interface
- then
- return False;
- end if;
-
- when Secondary_DT =>
- if Kind = Must_Be_Primary_DT
- or else Kind = Must_Be_Interface
- then
- return False;
- end if;
-
- when Abstract_Interface =>
- if Kind = Must_Be_Primary_DT
- or else Kind = Must_Be_Secondary_DT
- or else Kind = Must_Be_Primary_Or_Secondary_DT
- then
- return False;
- end if;
-
- when others =>
- return False;
-
- end case;
-
- return True;
- end Check_Signature;
-
- ----------------
- -- Check_Size --
- ----------------
-
- function Check_Size
- (Old_T : Tag;
- New_T : Tag;
- Entry_Count : Natural) return Boolean
- is
- Max_Entries_Old : constant Natural := Get_Num_Prim_Ops (Old_T);
- Max_Entries_New : constant Natural := Get_Num_Prim_Ops (New_T);
-
- begin
- return Entry_Count <= Max_Entries_Old
- and then Entry_Count <= Max_Entries_New;
- end Check_Size;
-
-------------------
-- CW_Membership --
-------------------
function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
Pos : Integer;
begin
- pragma Assert (Check_Signature (Obj_Tag, Must_Be_Primary_DT));
- pragma Assert (Check_Signature (Typ_Tag, Must_Be_Primary_DT));
Pos := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
return Pos >= 0 and then TSD (Obj_Tag).Tags_Table (Pos) = Typ_Tag;
end CW_Membership;
+ ------------------
+ -- Base_Address --
+ ------------------
+
+ function Base_Address (This : System.Address) return System.Address is
+ begin
+ return This - Offset_To_Top (This);
+ end Base_Address;
+
--------------
-- Displace --
--------------
(This : System.Address;
T : Tag) return System.Address
is
- Curr_DT : constant Tag := To_Tag_Ptr (This).all;
Iface_Table : Interface_Data_Ptr;
Obj_Base : System.Address;
Obj_DT : Tag;
Obj_TSD : Type_Specific_Data_Ptr;
begin
- pragma Assert
- (Check_Signature (Curr_DT, Must_Be_Primary_Or_Secondary_DT));
- pragma Assert
- (Check_Signature (T, Must_Be_Interface));
-
Obj_Base := This - Offset_To_Top (This);
Obj_DT := To_Tag_Ptr (Obj_Base).all;
-
- pragma Assert
- (Check_Signature (Obj_DT, Must_Be_Primary_DT));
-
Obj_TSD := TSD (Obj_DT);
Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop
- if Iface_Table.Table (Id).Iface_Tag = T then
+ if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then
-- Case of Static value of Offset_To_Top
- if Iface_Table.Table (Id).Static_Offset_To_Top then
- Obj_Base :=
- Obj_Base + Iface_Table.Table (Id).Offset_To_Top_Value;
+ if Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top then
+ Obj_Base := Obj_Base +
+ Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value;
-- Otherwise we call the function generated by the expander
-- to provide us with this value
Obj_Base :=
Obj_Base +
To_Offset_To_Top_Function_Ptr
- (Iface_Table.Table (Id).Offset_To_Top_Func).all
+ (Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func).all
(Obj_Base);
end if;
Obj_DT := To_Tag_Ptr (Obj_Base).all;
-
- pragma Assert
- (Check_Signature (Obj_DT, Must_Be_Secondary_DT));
-
return Obj_Base;
end if;
end loop;
-- that are contained in the dispatch table referenced by Obj'Tag.
function IW_Membership (This : System.Address; T : Tag) return Boolean is
- Curr_DT : constant Tag := To_Tag_Ptr (This).all;
Iface_Table : Interface_Data_Ptr;
Last_Id : Natural;
Obj_Base : System.Address;
Obj_TSD : Type_Specific_Data_Ptr;
begin
- pragma Assert
- (Check_Signature (Curr_DT, Must_Be_Primary_Or_Secondary_DT));
- pragma Assert
- (Check_Signature (T, Must_Be_Primary_Or_Interface));
-
Obj_Base := This - Offset_To_Top (This);
Obj_DT := To_Tag_Ptr (Obj_Base).all;
-
- pragma Assert
- (Check_Signature (Obj_DT, Must_Be_Primary_DT));
-
- Obj_TSD := TSD (Obj_DT);
- Last_Id := Obj_TSD.Idepth;
+ Obj_TSD := TSD (Obj_DT);
+ Last_Id := Obj_TSD.Idepth;
-- Look for the tag in the table of interfaces
if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop
- if Iface_Table.Table (Id).Iface_Tag = T then
+ if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then
return True;
end if;
end loop;
--------------------
function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
- Int_Tag : Tag;
+ Int_Tag : constant Tag := Internal_Tag (External);
begin
- pragma Assert (Check_Signature (Ancestor, Must_Be_Primary_DT));
- Int_Tag := Internal_Tag (External);
- pragma Assert (Check_Signature (Int_Tag, Must_Be_Primary_DT));
-
if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
raise Tag_Error;
end if;
raise Tag_Error;
end if;
- pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
Result := TSD (T).Expanded_Name;
return Result (1 .. Length (Result));
end Expanded_Name;
raise Tag_Error;
end if;
- pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
Result := TSD (T).External_Tag;
-
return Result (1 .. Length (Result));
end External_Tag;
- ----------------------
- -- Get_Access_Level --
- ----------------------
-
- function Get_Access_Level (T : Tag) return Natural is
- begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
- return TSD (T).Access_Level;
- end Get_Access_Level;
-
---------------------
-- Get_Entry_Index --
---------------------
function Get_Entry_Index (T : Tag; Position : Positive) return Positive is
begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
- pragma Assert (Position <= Get_Num_Prim_Ops (T));
return SSD (T).SSD_Table (Position).Index;
end Get_Entry_Index;
function Get_External_Tag (T : Tag) return System.Address is
begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
return To_Address (TSD (T).External_Tag);
end Get_External_Tag;
- ----------------------
- -- Get_Num_Prim_Ops --
- ----------------------
-
- function Get_Num_Prim_Ops (T : Tag) return Natural is
- begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
-
- if Is_Primary_DT (T) then
- return TSD (T).Num_Prim_Ops;
- else
- return OSD (T).Num_Prim_Ops;
- end if;
- end Get_Num_Prim_Ops;
-
- --------------------------------
- -- Get_Predef_Prim_Op_Address --
- --------------------------------
-
- function Get_Predefined_Prim_Op_Address
- (T : Tag;
- Position : Positive) return System.Address
- is
- begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
- pragma Assert (Position <= Default_Prim_Op_Count);
- return Predefined_DT (T).Prims_Ptr (Position);
- end Get_Predefined_Prim_Op_Address;
-
- -------------------------
- -- Get_Prim_Op_Address --
- -------------------------
-
- function Get_Prim_Op_Address
- (T : Tag;
- Position : Positive) return System.Address
- is
- begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
- pragma Assert (Position <= Get_Num_Prim_Ops (T));
- return T.Prims_Ptr (Position);
- end Get_Prim_Op_Address;
-
----------------------
-- Get_Prim_Op_Kind --
----------------------
Position : Positive) return Prim_Op_Kind
is
begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
- pragma Assert (Position <= Get_Num_Prim_Ops (T));
return SSD (T).SSD_Table (Position).Kind;
end Get_Prim_Op_Kind;
Position : Positive) return Positive
is
begin
- pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
- pragma Assert (Position <= Get_Num_Prim_Ops (T));
- return OSD (T).OSD_Table (Position);
+ if Is_Primary_DT (T) then
+ return Position;
+ else
+ return OSD (T).OSD_Table (Position);
+ end if;
end Get_Offset_Index;
-------------------
function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is
begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
return TSD (T).RC_Offset;
end Get_RC_Offset;
- ---------------------------
- -- Get_Remotely_Callable --
- ---------------------------
-
- function Get_Remotely_Callable (T : Tag) return Boolean is
- begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
- return TSD (T).Remotely_Callable;
- end Get_Remotely_Callable;
-
---------------------
-- Get_Tagged_Kind --
---------------------
Tagged_Kind_Ptr : constant System.Address :=
To_Address (T) - K_Tagged_Kind;
begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
return To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all;
end Get_Tagged_Kind;
- --------------------
- -- Inherit_CPP_DT --
- --------------------
-
- procedure Inherit_CPP_DT
- (Old_T : Tag;
- New_T : Tag;
- Entry_Count : Natural)
- is
- begin
- New_T.Prims_Ptr (1 .. Entry_Count) := Old_T.Prims_Ptr (1 .. Entry_Count);
- end Inherit_CPP_DT;
-
- ----------------
- -- Inherit_DT --
- ----------------
-
- procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural) is
- subtype All_Predefined_Prims is
- Positive range 1 .. Default_Prim_Op_Count;
-
- begin
- pragma Assert (Check_Signature (Old_T, Must_Be_Primary_Or_Secondary_DT));
- pragma Assert (Check_Signature (New_T, Must_Be_Primary_Or_Secondary_DT));
- pragma Assert (Check_Size (Old_T, New_T, Entry_Count));
-
- if Old_T /= null then
-
- -- Inherit the primitives of the parent
-
- New_T.Prims_Ptr (1 .. Entry_Count) :=
- Old_T.Prims_Ptr (1 .. Entry_Count);
-
- -- Inherit the predefined primitives of the parent
-
- -- NOTE: In the following assignment we have to unactivate a warning
- -- generated by the compiler because of the following declaration of
- -- the Dispatch_Table:
-
- -- Prims_Ptr : Address_Array (1 .. 1);
-
- -- This is a dummy declaration that is expanded by the frontend to
- -- the correct size of the dispatch table corresponding with each
- -- tagged type. As a consequence, if we try to use a constant to
- -- copy the predefined elements (ie. Prims_Ptr (1 .. 15) := ...)
- -- the compiler generates a warning indicating that Constraint_Error
- -- will be raised at run-time (which is not true in this specific
- -- case).
-
- pragma Warnings (Off);
- Predefined_DT (New_T).Prims_Ptr (All_Predefined_Prims) :=
- Predefined_DT (Old_T).Prims_Ptr (All_Predefined_Prims);
- pragma Warnings (On);
- end if;
- end Inherit_DT;
-
- -----------------
- -- Inherit_TSD --
- -----------------
-
- procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag) is
- New_TSD_Ptr : Type_Specific_Data_Ptr;
- New_Iface_Table_Ptr : Interface_Data_Ptr;
- Old_TSD_Ptr : Type_Specific_Data_Ptr;
- Old_Iface_Table_Ptr : Interface_Data_Ptr;
-
- begin
- pragma Assert (Check_Signature (New_Tag, Must_Be_Primary_Or_Interface));
- New_TSD_Ptr := TSD (New_Tag);
-
- if Old_Tag /= null then
- pragma Assert
- (Check_Signature (Old_Tag, Must_Be_Primary_Or_Interface));
- Old_TSD_Ptr := TSD (Old_Tag);
- New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1;
-
- -- Copy the "table of ancestor tags" plus the "table of interfaces"
- -- of the parent.
-
- New_TSD_Ptr.Tags_Table (1 .. New_TSD_Ptr.Idepth) :=
- Old_TSD_Ptr.Tags_Table (0 .. Old_TSD_Ptr.Idepth);
-
- -- Copy the table of interfaces of the parent
-
- if not System."=" (Old_TSD_Ptr.Ifaces_Table_Ptr,
- System.Null_Address)
- then
- Old_Iface_Table_Ptr :=
- To_Interface_Data_Ptr (Old_TSD_Ptr.Ifaces_Table_Ptr);
- New_Iface_Table_Ptr :=
- To_Interface_Data_Ptr (New_TSD_Ptr.Ifaces_Table_Ptr);
-
- New_Iface_Table_Ptr.Table (1 .. Old_Iface_Table_Ptr.Nb_Ifaces) :=
- Old_Iface_Table_Ptr.Table (1 .. Old_Iface_Table_Ptr.Nb_Ifaces);
- end if;
-
- else
- New_TSD_Ptr.Idepth := 0;
- end if;
-
- New_TSD_Ptr.Tags_Table (0) := New_Tag;
- end Inherit_TSD;
-
-----------------------------
-- Interface_Ancestor_Tags --
-----------------------------
Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces);
begin
for J in 1 .. Iface_Table.Nb_Ifaces loop
- Table (J) := Iface_Table.Table (J).Iface_Tag;
+ Table (J) := Iface_Table.Ifaces_Table (J).Iface_Tag;
end loop;
return Table;
OSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - K_Typeinfo);
begin
- pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
return To_Object_Specific_Data_Ptr (OSD_Ptr.all);
end OSD;
-- Access to the _size primitive of the parent
begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
Parent_Tag := TSD (T).Tags_Table (Parent_Slot);
F := To_Acc_Size (Predefined_DT (Parent_Tag).Prims_Ptr (Size_Slot));
raise Tag_Error;
end if;
- pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
-
-- The Parent_Tag of a root-level tagged type is defined to be No_Tag.
-- The first entry in the Ancestors_Tags array will be null for such
-- a type, but it's better to be explicit about returning No_Tag in
Iface_Table : Interface_Data_Ptr;
begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
- pragma Assert (Check_Signature (Interface_T, Must_Be_Interface));
-
New_T_TSD := TSD (T);
Iface_Table := To_Interface_Data_Ptr (New_T_TSD.Ifaces_Table_Ptr);
-
- pragma Assert (Position <= Iface_Table.Nb_Ifaces);
- Iface_Table.Table (Position).Iface_Tag := Interface_T;
+ Iface_Table.Ifaces_Table (Position).Iface_Tag := Interface_T;
end Register_Interface_Tag;
------------------
External_Tag_HTable.Set (T);
end Register_Tag;
- ----------------------
- -- Set_Access_Level --
- ----------------------
-
- procedure Set_Access_Level (T : Tag; Value : Natural) is
- begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
- TSD (T).Access_Level := Value;
- end Set_Access_Level;
-
---------------------
-- Set_Entry_Index --
---------------------
Value : Positive)
is
begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
- pragma Assert (Position <= Get_Num_Prim_Ops (T));
SSD (T).SSD_Table (Position).Index := Value;
end Set_Entry_Index;
- -----------------------
- -- Set_Expanded_Name --
- -----------------------
-
- procedure Set_Expanded_Name (T : Tag; Value : System.Address) is
- begin
- pragma Assert
- (Check_Signature (T, Must_Be_Primary_Or_Interface));
- TSD (T).Expanded_Name := To_Cstring_Ptr (Value);
- end Set_Expanded_Name;
-
- ----------------------
- -- Set_External_Tag --
- ----------------------
-
- procedure Set_External_Tag (T : Tag; Value : System.Address) is
- begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
- TSD (T).External_Tag := To_Cstring_Ptr (Value);
- end Set_External_Tag;
-
-------------------------
-- Set_Interface_Table --
-------------------------
procedure Set_Interface_Table (T : Tag; Value : System.Address) is
begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
TSD (T).Ifaces_Table_Ptr := Value;
end Set_Interface_Table;
- ----------------------
- -- Set_Num_Prim_Ops --
- ----------------------
-
- procedure Set_Num_Prim_Ops (T : Tag; Value : Natural) is
- begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
-
- if Is_Primary_DT (T) then
- TSD (T).Num_Prim_Ops := Value;
- else
- OSD (T).Num_Prim_Ops := Value;
- end if;
- end Set_Num_Prim_Ops;
-
----------------------
-- Set_Offset_Index --
----------------------
Value : Positive)
is
begin
- pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
- pragma Assert (Position <= Get_Num_Prim_Ops (T));
OSD (T).OSD_Table (Position) := Value;
end Set_Offset_Index;
Obj_TSD : Type_Specific_Data_Ptr;
begin
if System."=" (This, System.Null_Address) then
- pragma Assert
- (Check_Signature (Interface_T, Must_Be_Primary_DT));
- pragma Assert (Offset_Value = 0);
-
Offset_To_Top :=
To_Storage_Offset_Ptr (To_Address (Interface_T) - K_Offset_To_Top);
Offset_To_Top.all := Offset_Value;
Prim_DT := To_Tag_Ptr (This).all;
- pragma Assert
- (Check_Signature (Prim_DT, Must_Be_Primary_DT));
-
-- Save the offset to top field in the secondary dispatch table.
if Offset_Value /= 0 then
Offset_To_Top :=
To_Storage_Offset_Ptr (To_Address (Sec_DT) - K_Offset_To_Top);
- pragma Assert
- (Check_Signature (Sec_DT, Must_Be_Secondary_DT));
-
if Is_Static then
Offset_To_Top.all := Offset_Value;
else
if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop
- if Iface_Table.Table (Id).Iface_Tag = Interface_T then
- Iface_Table.Table (Id).Static_Offset_To_Top := Is_Static;
+ if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then
+ Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := Is_Static;
if Is_Static then
- Iface_Table.Table (Id).Offset_To_Top_Value := Offset_Value;
+ Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value
+ := Offset_Value;
else
- Iface_Table.Table (Id).Offset_To_Top_Func := Offset_Func;
+ Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func
+ := Offset_Func;
end if;
return;
OSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - K_Typeinfo);
begin
- pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
OSD_Ptr.all := Value;
end Set_OSD;
- ------------------------------------
- -- Set_Predefined_Prim_Op_Address --
- ------------------------------------
-
- procedure Set_Predefined_Prim_Op_Address
- (T : Tag;
- Position : Positive;
- Value : System.Address)
- is
- begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
- pragma Assert (Position >= 1 and then Position <= Default_Prim_Op_Count);
- Predefined_DT (T).Prims_Ptr (Position) := Value;
- end Set_Predefined_Prim_Op_Address;
-
- -------------------------
- -- Set_Prim_Op_Address --
- -------------------------
-
- procedure Set_Prim_Op_Address
- (T : Tag;
- Position : Positive;
- Value : System.Address)
- is
- begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
- pragma Assert (Position <= Get_Num_Prim_Ops (T));
- T.Prims_Ptr (Position) := Value;
- end Set_Prim_Op_Address;
-
----------------------
-- Set_Prim_Op_Kind --
----------------------
Value : Prim_Op_Kind)
is
begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
- pragma Assert (Position <= Get_Num_Prim_Ops (T));
SSD (T).SSD_Table (Position).Kind := Value;
end Set_Prim_Op_Kind;
- -------------------
- -- Set_RC_Offset --
- -------------------
-
- procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is
- begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
- TSD (T).RC_Offset := Value;
- end Set_RC_Offset;
-
- ---------------------------
- -- Set_Remotely_Callable --
- ---------------------------
-
- procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is
- begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
- TSD (T).Remotely_Callable := Value;
- end Set_Remotely_Callable;
-
-------------------
-- Set_Signature --
-------------------
procedure Set_SSD (T : Tag; Value : System.Address) is
begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
TSD (T).SSD_Ptr := Value;
end Set_SSD;
Tagged_Kind_Ptr : constant System.Address :=
To_Address (T) - K_Tagged_Kind;
begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all := Value;
end Set_Tagged_Kind;
- -------------
- -- Set_TSD --
- -------------
-
- procedure Set_TSD (T : Tag; Value : System.Address) is
- TSD_Ptr : Addr_Ptr;
- begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
- TSD_Ptr := To_Addr_Ptr (To_Address (T) - K_Typeinfo);
- TSD_Ptr.all := Value;
- end Set_TSD;
-
---------
-- SSD --
---------
function SSD (T : Tag) return Select_Specific_Data_Ptr is
begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
return To_Select_Specific_Data_Ptr (TSD (T).SSD_Ptr);
end SSD;
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - K_Typeinfo);
begin
- pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
return To_Type_Specific_Data_Ptr (TSD_Ptr.all);
end TSD;
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
+ -- Structure of the GNAT Primary Dispatch Table
+
+ -- +--------------------+
+ -- | table of |
+ -- :predefined primitive:
+ -- | ops pointers |
+ -- +--------------------+
+ -- | Signature |
+ -- +--------------------+
+ -- | Tagged_Kind |
+ -- +--------------------+
+ -- | Offset_To_Top |
+ -- +--------------------+
+ -- |Typeinfo_Ptr/TSD_Ptr---> Type Specific Data
+ -- Tag ---> +--------------------+ +-------------------+
+ -- | table of | | inheritance depth |
+ -- : primitive ops : +-------------------+
+ -- | pointers | | access level |
+ -- +--------------------+ +-------------------+
+ -- | expanded name |
+ -- +-------------------+
+ -- | external tag |
+ -- +-------------------+
+ -- | hash table link |
+ -- +-------------------+
+ -- | remotely callable |
+ -- +-------------------+
+ -- | rec ctrler offset |
+ -- +-------------------+
+ -- | num prim ops |
+ -- +-------------------+
+ -- | Ifaces_Table_Ptr --> Interface Data
+ -- +-------------------+ +------------+
+ -- Select Specific Data <---- SSD_Ptr | | table |
+ -- +------------------+ +-------------------+ : of :
+ -- |table of primitive| | table of | | interfaces |
+ -- : operation : : ancestor : +------------+
+ -- | kinds | | tags |
+ -- +------------------+ +-------------------+
+ -- |table of |
+ -- : entry :
+ -- | indices |
+ -- +------------------+
+
+ -- Structure of the GNAT Secondary Dispatch Table
+
+ -- +-----------------------+
+ -- | table of |
+ -- : predefined primitive :
+ -- | ops pointers |
+ -- +-----------------------+
+ -- | Signature |
+ -- +-----------------------+
+ -- | Tagged_Kind |
+ -- +-----------------------+
+ -- | Offset_To_Top |
+ -- +-----------------------+
+ -- | OSD_Ptr |---> Object Specific Data
+ -- Tag ---> +-----------------------+ +---------------+
+ -- | table of | | num prim ops |
+ -- : primitive op : +---------------+
+ -- | thunk pointers | | table of |
+ -- +-----------------------+ + primitive |
+ -- | op offsets |
+ -- +---------------+
+
+ -- 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
-- where Nb_prim is the number of primitive operations of the given
-- type and Idepth its inheritance depth.
- -- 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 Address_Array is array (Natural range <>) of System.Address;
+ pragma Suppress (Index_Check, On => Address_Array);
+ -- The reason we suppress index checks is that in the dispatch table,
+ -- the component of this type is declared with a dummy size of 1, the
+ -- actual size depending on the number of primitive operations.
+
+ type Dispatch_Table is record
+
+ -- According to the C++ ABI the components Offset_To_Top and
+ -- Typeinfo_Ptr are stored just "before" the dispatch table (that is,
+ -- the Prims_Ptr table), and they are referenced with negative offsets
+ -- referring to the base of the dispatch table. The _Tag (or the
+ -- VTable_Ptr in C++ terminology) must point to the base of the virtual
+ -- table, just after these components, to point to the Prims_Ptr table.
+ -- For this purpose the expander generates a Prims_Ptr table that has
+ -- enough space for these additional components, and generates code that
+ -- displaces the _Tag to point after these components.
+
+ -- Signature : Signature_Kind;
+ -- Tagged_Kind : Tagged_Kind;
+ -- Offset_To_Top : Natural;
+ -- Typeinfo_Ptr : System.Address;
+
+ Prims_Ptr : Address_Array (1 .. 1);
+ -- The size of the Prims_Ptr array actually depends on the tagged type
+ -- to which it applies. For each tagged type, the expander computes the
+ -- actual array size, allocates the Dispatch_Table record accordingly,
+ -- and generates code that displaces the base of the record after the
+ -- Typeinfo_Ptr component. For this reason the first two components have
+ -- been commented in the previous declaration. The access to these
+ -- components is done by means of local functions.
+ --
+ -- To avoid the use of discriminants to define the actual size of the
+ -- dispatch table, we used to declare the tag as a pointer to a record
+ -- that contains an arbitrary array of addresses, using Positive as its
+ -- index. This ensures that there are never range checks when accessing
+ -- the dispatch table, but it prevents GDB from displaying tagged types
+ -- properly. A better approach is to declare this record type as holding
+ -- small number of addresses, and to explicitly suppress checks on it.
+ --
+ -- Note that in both cases, this type is never allocated, and serves
+ -- only to declare the corresponding access type.
+ end record;
+
+ subtype Cstring is String (Positive);
+ type Cstring_Ptr is access all Cstring;
+ pragma No_Strict_Aliasing (Cstring_Ptr);
+
+ -- We suppress index checks because the declared size in the record below
+ -- is a dummy size of one (see below).
+
+ type Tag_Table is array (Natural range <>) of Tag;
+ pragma Suppress_Initialization (Tag_Table);
+ pragma Suppress (Index_Check, On => Tag_Table);
+
+ package SSE renames System.Storage_Elements;
+
+ -- Type specific data types
+
+ type Type_Specific_Data (Idepth : Natural) is record
+ -- Inheritance Depth Level: Used to implement the membership test
+ -- associated with single inheritance of tagged types in constant-time.
+ -- It also indicates the size of the Tags_Table component.
+
+ Access_Level : Natural;
+ -- Accessibility level required to give support to Ada 2005 nested type
+ -- extensions. This feature allows safe nested type extensions by
+ -- shifting the accessibility checks to certain operations, rather than
+ -- being enforced at the type declaration. In particular, by performing
+ -- run-time accessibility checks on class-wide allocators, class-wide
+ -- function return, and class-wide stream I/O, the danger of objects
+ -- outliving their type declaration can be eliminated (Ada 2005: AI-344)
+
+ Expanded_Name : Cstring_Ptr;
+ External_Tag : Cstring_Ptr;
+ HT_Link : Tag;
+ -- Components used to support to the Ada.Tags subprograms in RM 3.9.
+ -- Note: Expanded_Name is referenced by GDB ???
+
+ Remotely_Callable : Boolean;
+ -- Used to check ARM E.4 (18)
+
+ RC_Offset : SSE.Storage_Offset;
+ -- Controller Offset: Used to give support to tagged controlled objects
+ -- (see Get_Deep_Controller at s-finimp)
+
+ Ifaces_Table_Ptr : System.Address;
+ -- Pointer to the table of interface tags. It is used to implement the
+ -- membership test associated with interfaces and also for backward
+ -- abstract interface type conversions (Ada 2005:AI-251)
+
+ SSD_Ptr : System.Address;
+ -- Pointer to a table of records used in dispatching selects. This
+ -- field has a meaningful value for all tagged types that implement
+ -- a limited, protected, synchronized or task interfaces and have
+ -- non-predefined primitive operations.
+
+ Tags_Table : Tag_Table (0 .. Idepth);
+ -- Table of ancestor tags. Its size actually depends on the inheritance
+ -- depth level of the tagged type.
+ end record;
+
+ -- Declarations for the table of interfaces
+
+ type Interface_Data_Element is record
+ Iface_Tag : Tag;
+ Static_Offset_To_Top : Boolean;
+ Offset_To_Top_Value : System.Storage_Elements.Storage_Offset;
+ Offset_To_Top_Func : System.Address;
+ end record;
+ -- If some ancestor of the tagged type has discriminants the field
+ -- Static_Offset_To_Top is False and the field Offset_To_Top_Func
+ -- is used to store the address of the function generated by the
+ -- expander which provides this value; otherwise Static_Offset_To_Top
+ -- is True and such value is stored in the Offset_To_Top_Value field.
+
+ type Interfaces_Array is
+ array (Natural range <>) of Interface_Data_Element;
+
+ type Interface_Data (Nb_Ifaces : Positive) is record
+ Ifaces_Table : Interfaces_Array (1 .. Nb_Ifaces);
+ end record;
+
+ -- Declaration of tag types
- type Dispatch_Table;
type Tag is access all Dispatch_Table;
+ type Tag_Ptr is access Tag;
type Interface_Tag is access all Dispatch_Table;
+ type Type_Specific_Data_Ptr is access all Type_Specific_Data;
No_Tag : constant Tag := null;
- type Interface_Data (Nb_Ifaces : Positive);
type Interface_Data_Ptr is access all Interface_Data;
-- Table of abstract interfaces used to give support to backward interface
-- conversions and also to IW_Membership.
-- 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;
-
-- Primitive operation kinds. These values differentiate the kinds of
-- callable entities stored in the dispatch table. Certain kinds may
-- not be used, but are added for completeness.
type Tagged_Kind_Ptr is access all Tagged_Kind;
Default_Prim_Op_Count : constant Positive := 15;
- -- Number of predefined primitive operations added by the Expander for a
- -- tagged type (must match Exp_Disp.Default_Prim_Op_Count).
+ -- Maximum number of predefined primitive operations of a tagged type.
type Signature_Kind is
(Unknown,
-- 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;
+ DT_Min_Prologue_Size : constant SSE.Storage_Count :=
+ SSE.Storage_Count
+ (2 * (Standard'Address_Size /
+ System.Storage_Unit));
+ -- Size of the hidden part of the dispatch table used when the program
+ -- is compiled under restriction No_Dispatching_Calls. It contains the
+ -- pointer to the TSD record plus a dummy entry whose address is used
+ -- at run-time as the Tag.
+
+ DT_Prologue_Size : constant SSE.Storage_Count :=
+ 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));
+ -- Size of the Signature field of the dispatch table
+
+ DT_Tagged_Kind_Size : constant SSE.Storage_Count :=
+ SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
+ -- 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));
+ -- 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));
+ -- 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));
+ -- 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
+
+ -- Constants used by the code generated by the frontend to get access
+ -- to the header of the dispatch table.
+
+ K_Typeinfo : constant SSE.Storage_Count := DT_Typeinfo_Ptr_Size;
+ K_Offset_To_Top : constant SSE.Storage_Count :=
+ System.Storage_Elements."+"
+ (K_Typeinfo, DT_Offset_To_Top_Size);
+ K_Tagged_Kind : constant SSE.Storage_Count :=
+ System.Storage_Elements."+"
+ (K_Offset_To_Top, DT_Tagged_Kind_Size);
+ K_Signature : constant SSE.Storage_Count :=
+ System.Storage_Elements."+"
+ (K_Tagged_Kind, DT_Signature_Size);
+
+ -- The following subprogram specifications are placed here instead of
+ -- the package body to see them from the frontend through rtsfind.
+
+ function Base_Address (This : System.Address) return System.Address;
+ -- Ada 2005 (AI-251): Displace "This" to point to the base address of
+ -- the object (that is, the address of the primary tag of the object).
function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
-- 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;
- -- 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
- -- implements a given type (Iface_CW_Typ in T'Class). For example:
- --
- -- type I is interface;
- -- type T is tagged ...
- --
- -- function Test (O : I'Class) is
- -- begin
- -- return O in T'Class.
- -- end Test;
-
function Displace (This : System.Address; T : Tag) return System.Address;
- -- (Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch
+ -- Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch
-- table of T.
- function Get_Access_Level (T : Tag) return Natural;
- -- Given the tag associated with a type, returns the accessibility level
- -- of the type.
-
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.
+ -- Ada 2005 (AI-251): 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.
+ -- Returns address of a null terminated string containing the external name
function Get_Offset_Index
(T : 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_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;
- -- 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).
+ -- Ada 2005 (AI-251): 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_Kind
(T : Tag;
Position : Positive) return Prim_Op_Kind;
- -- Return a primitive operation's kind given a dispatch table T and a
- -- position of a primitive operation in T.
+ -- Ada 2005 (AI-251): Return a primitive operation's kind given a dispatch
+ -- table T and a position of a primitive operation in T.
function Get_RC_Offset (T : Tag) return SSE.Storage_Offset;
-- Return the Offset of the implicit record controller when the object
-- it is exported manually in order to avoid changing completely the
-- organization of the run time.
- function Get_Remotely_Callable (T : Tag) return Boolean;
- -- Return the value previously set by Set_Remotely_Callable
-
function Get_Tagged_Kind (T : Tag) return Tagged_Kind;
- -- Given a pointer to either a primary or a secondary dispatch table,
- -- return the tagged kind of a type in the context of concurrency and
- -- limitedness.
-
- procedure Inherit_CPP_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 CPP ancestor and the number of primitive ops that
- -- are inherited (Entry_Count).
-
- 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).
+ -- Ada 2005 (AI-345): Given a pointer to either a primary or a secondary
+ -- dispatch table, return the tagged kind of a type in the context of
+ -- concurrency and limitedness.
- procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag);
- -- Initialize the TSD of a type knowing the tag of the direct ancestor
+ 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
+ -- implements a given type (Iface_CW_Typ in T'Class). For example:
+ --
+ -- type I is interface;
+ -- type T is tagged ...
+ --
+ -- function Test (O : I'Class) is
+ -- begin
+ -- return O in T'Class.
+ -- end Test;
function Offset_To_Top
(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. If the parent of the tagged type
- -- has discriminants this value is stored in a record component just
- -- immediately after the tag component.
+ -- Ada 2005 (AI-251): Returns the current value of the offset_to_top
+ -- component available in 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,
- -- retrieve the address of the record containing the Objet Specific
+ -- retrieve the address of the record containing the Object Specific
-- Data table.
function Parent_Size
-- Insert the Tag and its associated external_tag in a table for the
-- sake of Internal_Tag
- procedure Set_Access_Level (T : Tag; Value : Natural);
- -- Sets the accessibility level of the tagged type associated with T
- -- in its TSD.
-
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_Expanded_Name (T : Tag; Value : System.Address);
- -- Set the address of the string containing the expanded name
- -- in the Dispatch table.
-
- procedure Set_External_Tag (T : Tag; Value : System.Address);
- -- Set the address of the string containing the external tag
- -- in the Dispatch table.
+ -- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's
+ -- TSD table indexed by Position.
procedure Set_Interface_Table (T : Tag; Value : System.Address);
-- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, stores the
-- pointer to the table of interfaces.
- 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 : Tag;
Position : Positive;
Value : Positive);
- -- Set the offset value of a primitive operation in a secondary dispatch
- -- table denoted by T, indexed by Position.
+ -- Ada 2005 (AI-345): Set the offset value of a primitive operation in a
+ -- secondary dispatch table denoted by T, indexed by Position.
procedure Set_Offset_To_Top
(This : System.Address;
-- secondary dispatch table.
procedure Set_OSD (T : 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_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;
- Value : System.Address);
- -- Given a pointer to a dispatch Table (T) and a position in the dispatch
- -- Table put the address of the virtual function in it (used for
- -- overriding).
+ -- Ada 2005 (AI-251): 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_Kind
(T : Tag;
Position : Positive;
Value : Prim_Op_Kind);
- -- Set the kind of a primitive operation in T's TSD table indexed by
- -- Position.
-
- procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset);
- -- Sets the Offset of the implicit record controller when the object
- -- has controlled components. Set to O otherwise.
-
- procedure Set_Remotely_Callable (T : Tag; Value : Boolean);
- -- Set to true if the type has been declared in a context described
- -- in E.4 (18).
+ -- Ada 2005 (AI-251): Set the kind of a primitive operation in T's TSD
+ -- table indexed by Position.
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.
+ -- Ada 2005 (AI-345): Given a pointer T to a dispatch Table, stores the
+ -- pointer to the record containing the Select Specific Data generated by
+ -- GNAT.
procedure Set_Tagged_Kind (T : Tag; Value : Tagged_Kind);
- -- Set the tagged kind of a type in either a primary or a secondary
- -- dispatch table denoted by T.
-
- 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.
+ -- Ada 2005 (AI-345): Set the tagged kind of a type in either a primary or
+ -- a secondary dispatch table denoted by T.
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.
+ -- Ada 2005 (AI-251): 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, retrieves the address of the
-- record containing the Type Specific Data generated by GNAT.
- DT_Prologue_Size : constant SSE.Storage_Count :=
- 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));
- -- Size of the Signature field of the dispatch table
-
- DT_Tagged_Kind_Size : constant SSE.Storage_Count :=
- SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
- -- 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));
- -- 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));
- -- 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));
- -- 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));
- -- 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));
- -- Size of each ancestor tag entry in the TSD
-
- type Address_Array is array (Natural range <>) of System.Address;
- pragma Suppress (Index_Check, On => Address_Array);
- -- The reason we suppress index checks is that in the body, objects
- -- of this type are declared with a dummy size of 1, the actual size
- -- depending on the number of primitive operations.
-
-- 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;
function To_Type_Specific_Data_Ptr is
new Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
- function To_Address is
- new Unchecked_Conversion (Interface_Tag, System.Address);
-
function To_Address is
new Unchecked_Conversion (Tag, System.Address);
- function To_Address is
- new Unchecked_Conversion (Type_Specific_Data_Ptr, System.Address);
-
function To_Interface_Data_Ptr is
new Unchecked_Conversion (System.Address, Interface_Data_Ptr);
pragma Inline_Always (CW_Membership);
pragma Inline_Always (Displace);
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_Predefined_Prim_Op_Address);
- 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 (Get_Tagged_Kind);
- 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_Interface_Table);
- 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);
pragma Inline_Always (Set_Tagged_Kind);
pragma Inline_Always (SSD);
pragma Inline_Always (TSD);
projects / gcc.git / commitdiff