blob: cfce83451b5270d7c625999ba9bd46f9ef67974c [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . T A G S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Exceptions;
with System.HTable;
with System.Storage_Elements; use System.Storage_Elements;
with System.WCh_Con; use System.WCh_Con;
with System.WCh_StW; use System.WCh_StW;
pragma Elaborate_All (System.HTable);
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
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
-- is used in the handling of dispatching triggers in select statements.
-- Nb_Prim is the number of non-predefined primitive operations.
end record;
-- Select specific data types
type Select_Specific_Data_Element is record
Index : Positive;
Kind : Prim_Op_Kind;
end record;
type Select_Specific_Data_Array is
array (Positive range <>) of Select_Specific_Data_Element;
type Select_Specific_Data (Nb_Prim : Positive) is record
SSD_Table : Select_Specific_Data_Array (1 .. Nb_Prim);
-- 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 --
---------------------------------------------
function To_Address is
new Unchecked_Conversion (Cstring_Ptr, System.Address);
function To_Cstring_Ptr is
new Unchecked_Conversion (System.Address, Cstring_Ptr);
------------------------------------------------
-- Unchecked Conversions for other components --
------------------------------------------------
type Acc_Size
is access function (A : System.Address) return Long_Long_Integer;
function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size);
-- The profile of the implicitly defined _size primitive
type Offset_To_Top_Function_Ptr is
access function (This : System.Address)
return System.Storage_Elements.Storage_Offset;
-- Type definition used to call the function that is generated by the
-- expander in case of tagged types with discriminants that have secondary
-- dispatch tables. This function provides the Offset_To_Top value in this
-- specific case.
function To_Offset_To_Top_Function_Ptr is
new Unchecked_Conversion (System.Address, Offset_To_Top_Function_Ptr);
type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset;
function To_Storage_Offset_Ptr is
new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
-----------------------
-- 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
-- table. This is Inline_Always since it is called from other Inline_
-- Always subprograms where we want no out of line code to be generated.
function Length (Str : Cstring_Ptr) return Natural;
-- Length of string represented by the given pointer (treating the string
-- as a C-style string, which is Nul terminated).
function Typeinfo_Ptr (T : Tag) return System.Address;
-- Returns the current value of the typeinfo_ptr component available in
-- the prologue of the dispatch table.
pragma Unreferenced (Typeinfo_Ptr);
-- These functions will be used for full compatibility with the C++ ABI
-------------------------
-- External_Tag_HTable --
-------------------------
type HTable_Headers is range 1 .. 64;
-- The following internal package defines the routines used for the
-- instantiation of a new System.HTable.Static_HTable (see below). See
-- spec in g-htable.ads for details of usage.
package HTable_Subprograms is
procedure Set_HT_Link (T : Tag; Next : Tag);
function Get_HT_Link (T : Tag) return Tag;
function Hash (F : System.Address) return HTable_Headers;
function Equal (A, B : System.Address) return Boolean;
end HTable_Subprograms;
package External_Tag_HTable is new System.HTable.Static_HTable (
Header_Num => HTable_Headers,
Element => Dispatch_Table,
Elmt_Ptr => Tag,
Null_Ptr => null,
Set_Next => HTable_Subprograms.Set_HT_Link,
Next => HTable_Subprograms.Get_HT_Link,
Key => System.Address,
Get_Key => Get_External_Tag,
Hash => HTable_Subprograms.Hash,
Equal => HTable_Subprograms.Equal);
------------------------
-- HTable_Subprograms --
------------------------
-- Bodies of routines for hash table instantiation
package body HTable_Subprograms is
-----------
-- Equal --
-----------
function Equal (A, B : System.Address) return Boolean is
Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
J : Integer := 1;
begin
loop
if Str1 (J) /= Str2 (J) then
return False;
elsif Str1 (J) = ASCII.NUL then
return True;
else
J := J + 1;
end if;
end loop;
end Equal;
-----------------
-- Get_HT_Link --
-----------------
function Get_HT_Link (T : Tag) return Tag is
begin
return TSD (T).HT_Link;
end Get_HT_Link;
----------
-- Hash --
----------
function Hash (F : System.Address) return HTable_Headers is
function H is new System.HTable.Hash (HTable_Headers);
Str : constant Cstring_Ptr := To_Cstring_Ptr (F);
Res : constant HTable_Headers := H (Str (1 .. Length (Str)));
begin
return Res;
end Hash;
-----------------
-- Set_HT_Link --
-----------------
procedure Set_HT_Link (T : Tag; Next : Tag) is
begin
TSD (T).HT_Link := Next;
end Set_HT_Link;
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 --
-------------------
-- Canonical implementation of Classwide Membership corresponding to:
-- Obj in Typ'Class
-- Each dispatch table contains a reference to a table of ancestors (stored
-- in the first part of the Tags_Table) and a count of the level of
-- inheritance "Idepth".
-- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
-- contained in the dispatch table referenced by Obj'Tag . Knowing the
-- level of inheritance of both types, this can be computed in constant
-- time by the formula:
-- Obj'tag.TSD.Ancestor_Tags (Obj'tag.TSD.Idepth - Typ'tag.TSD.Idepth)
-- = Typ'tag
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;
--------------
-- Displace --
--------------
function 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
-- 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;
-- Otherwise we call the function generated by the expander
-- to provide us with this value
else
Obj_Base :=
Obj_Base +
To_Offset_To_Top_Function_Ptr
(Iface_Table.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;
end if;
-- If the object does not implement the interface we must raise CE
raise Constraint_Error;
end Displace;
-------------------
-- IW_Membership --
-------------------
-- Canonical implementation of Classwide Membership corresponding to:
-- Obj in Iface'Class
-- Each dispatch table contains a table with the tags of all the
-- implemented interfaces.
-- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
-- 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_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_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;
-- Look for the tag in the table of interfaces
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
return True;
end if;
end loop;
end if;
-- Look for the tag in the ancestor tags table. This is required for:
-- Iface_CW in Typ'Class
for Id in 0 .. Last_Id loop
if Obj_TSD.Tags_Table (Id) = T then
return True;
end if;
end loop;
return False;
end IW_Membership;
--------------------
-- Descendant_Tag --
--------------------
function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
Int_Tag : Tag;
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;
return Int_Tag;
end Descendant_Tag;
-------------------
-- Expanded_Name --
-------------------
function Expanded_Name (T : Tag) return String is
Result : Cstring_Ptr;
begin
if T = No_Tag then
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;
------------------
-- External_Tag --
------------------
function External_Tag (T : Tag) return String is
Result : Cstring_Ptr;
begin
if T = No_Tag then
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;
----------------------
-- Get_External_Tag --
----------------------
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
Prim_Ops_DT : constant Tag := To_Tag (To_Address (T) - DT_Prologue_Size);
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
pragma Assert (Position <= Default_Prim_Op_Count);
return Prim_Ops_DT.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 --
----------------------
function Get_Prim_Op_Kind
(T : Tag;
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;
----------------------
-- Get_Offset_Index --
----------------------
function Get_Offset_Index
(T : Tag;
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);
end Get_Offset_Index;
-------------------
-- Get_RC_Offset --
-------------------
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 --
---------------------
function Get_Tagged_Kind (T : Tag) return Tagged_Kind is
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_DT --
----------------
procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural) is
Old_T_Prim_Ops : Tag;
New_T_Prim_Ops : Tag;
Size : Positive;
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
New_T.Prims_Ptr (1 .. Entry_Count) :=
Old_T.Prims_Ptr (1 .. Entry_Count);
Old_T_Prim_Ops := To_Tag (To_Address (Old_T) - DT_Prologue_Size);
New_T_Prim_Ops := To_Tag (To_Address (New_T) - DT_Prologue_Size);
Size := Default_Prim_Op_Count;
New_T_Prim_Ops.Prims_Ptr (1 .. Size) :=
Old_T_Prim_Ops.Prims_Ptr (1 .. Size);
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;
------------------
-- Internal_Tag --
------------------
function Internal_Tag (External : String) return Tag is
Ext_Copy : aliased String (External'First .. External'Last + 1);
Res : Tag;
begin
-- Make a copy of the string representing the external tag with
-- a null at the end.
Ext_Copy (External'Range) := External;
Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
Res := External_Tag_HTable.Get (Ext_Copy'Address);
if Res = null then
declare
Msg1 : constant String := "unknown tagged type: ";
Msg2 : String (1 .. Msg1'Length + External'Length);
begin
Msg2 (1 .. Msg1'Length) := Msg1;
Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
External;
Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2);
end;
end if;
return Res;
end Internal_Tag;
---------------------------------
-- Is_Descendant_At_Same_Level --
---------------------------------
function Is_Descendant_At_Same_Level
(Descendant : Tag;
Ancestor : Tag) return Boolean
is
begin
return CW_Membership (Descendant, Ancestor)
and then TSD (Descendant).Access_Level = TSD (Ancestor).Access_Level;
end Is_Descendant_At_Same_Level;
-------------------
-- Is_Primary_DT --
-------------------
function Is_Primary_DT (T : Tag) 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);
begin
return Sig_Values (2) = Primary_DT;
end Is_Primary_DT;
------------
-- Length --
------------
function Length (Str : Cstring_Ptr) return Natural is
Len : Integer := 1;
begin
while Str (Len) /= ASCII.Nul loop
Len := Len + 1;
end loop;
return Len - 1;
end Length;
-------------------
-- Offset_To_Top --
-------------------
function Offset_To_Top
(This : System.Address) return System.Storage_Elements.Storage_Offset
is
Curr_DT : constant Tag := To_Tag_Ptr (This).all;
Offset_To_Top : Storage_Offset_Ptr;
begin
Offset_To_Top := To_Storage_Offset_Ptr
(To_Address (Curr_DT) - K_Offset_To_Top);
if Offset_To_Top.all = SSE.Storage_Offset'Last then
Offset_To_Top := To_Storage_Offset_Ptr (This + Tag_Size);
end if;
return Offset_To_Top.all;
end Offset_To_Top;
---------
-- OSD --
---------
function OSD (T : Tag) return Object_Specific_Data_Ptr is
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;
-----------------
-- Parent_Size --
-----------------
function Parent_Size
(Obj : System.Address;
T : Tag) return SSE.Storage_Count
is
Parent_Tag : Tag;
-- The tag of the parent type through the dispatch table
Prim_Ops_DT : Tag;
-- The table of primitive operations of the parent
F : Acc_Size;
-- Access to the _size primitive of the parent. We assume that it is
-- always in the first slot of the dispatch table.
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
Parent_Tag := TSD (T).Tags_Table (1);
Prim_Ops_DT := To_Tag (To_Address (Parent_Tag) - DT_Prologue_Size);
F := To_Acc_Size (Prim_Ops_DT.Prims_Ptr (1));
-- Here we compute the size of the _parent field of the object
return SSE.Storage_Count (F.all (Obj));
end Parent_Size;
----------------
-- Parent_Tag --
----------------
function Parent_Tag (T : Tag) return Tag is
begin
if T = No_Tag then
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
-- this case.
if TSD (T).Idepth = 0 then
return No_Tag;
else
return TSD (T).Tags_Table (1);
end if;
end Parent_Tag;
----------------------------
-- Register_Interface_Tag --
----------------------------
procedure Register_Interface_Tag
(T : Tag;
Interface_T : Tag;
Position : Positive)
is
New_T_TSD : Type_Specific_Data_Ptr;
Iface_Table : Interface_Data_Ptr;
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
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;
end Register_Interface_Tag;
------------------
-- Register_Tag --
------------------
procedure Register_Tag (T : Tag) is
begin
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 --
---------------------
procedure Set_Entry_Index
(T : Tag;
Position : Positive;
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_DT));
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 --
----------------------
procedure Set_Offset_Index
(T : Tag;
Position : Positive;
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;
-----------------------
-- Set_Offset_To_Top --
-----------------------
procedure Set_Offset_To_Top
(This : System.Address;
Interface_T : Tag;
Is_Static : Boolean;
Offset_Value : System.Storage_Elements.Storage_Offset;
Offset_Func : System.Address)
is
Prim_DT : Tag;
Sec_Base : System.Address;
Sec_DT : Tag;
Offset_To_Top : Storage_Offset_Ptr;
Iface_Table : Interface_Data_Ptr;
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;
return;
end if;
-- "This" points to the primary DT and we must save Offset_Value in the
-- Offset_To_Top field of the corresponding secondary dispatch table.
Prim_DT := To_Tag_Ptr (This).all;
pragma Assert
(Check_Signature (Prim_DT, Must_Be_Primary_DT));
Sec_Base := This + Offset_Value;
Sec_DT := To_Tag_Ptr (Sec_Base).all;
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
Offset_To_Top.all := SSE.Storage_Offset'Last;
end if;
-- Save Offset_Value in the table of interfaces of the primary DT. This
-- data will be used by the subprogram "Displace" to give support to
-- backward abstract interface type conversions.
Obj_TSD := TSD (Prim_DT);
Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
-- Register the offset 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 = Interface_T then
Iface_Table.Table (Id).Static_Offset_To_Top := Is_Static;
if Is_Static then
Iface_Table.Table (Id).Offset_To_Top_Value := Offset_Value;
else
Iface_Table.Table (Id).Offset_To_Top_Func := Offset_Func;
end if;
return;
end if;
end loop;
end if;
-- If we arrive here there is some error in the run-time data structure
raise Program_Error;
end Set_Offset_To_Top;
-------------
-- Set_OSD --
-------------
procedure Set_OSD (T : Tag; Value : System.Address) is
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
Prim_Ops_DT : constant Tag := To_Tag (To_Address (T) - DT_Prologue_Size);
begin
pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
pragma Assert (Position >= 1 and then Position <= Default_Prim_Op_Count);
Prim_Ops_DT.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 --
----------------------
procedure Set_Prim_Op_Kind
(T : Tag;
Position : Positive;
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_Signature (T : Tag; Value : Signature_Kind) is
Signature : constant System.Address := To_Address (T) - K_Signature;
Sig_Ptr : constant Signature_Values_Ptr :=
To_Signature_Values_Ptr (Signature);
begin
Sig_Ptr.all (1) := Valid_Signature;
Sig_Ptr.all (2) := Value;
end Set_Signature;
-------------
-- Set_SSD --
-------------
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;
---------------------
-- Set_Tagged_Kind --
---------------------
procedure Set_Tagged_Kind (T : Tag; Value : Tagged_Kind) is
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;
------------------
-- Typeinfo_Ptr --
------------------
function Typeinfo_Ptr (T : Tag) return System.Address is
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - K_Typeinfo);
begin
return TSD_Ptr.all;
end Typeinfo_Ptr;
---------
-- TSD --
---------
function TSD (T : Tag) return Type_Specific_Data_Ptr is
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;
------------------------
-- Wide_Expanded_Name --
------------------------
WC_Encoding : Character;
pragma Import (C, WC_Encoding, "__gl_wc_encoding");
-- Encoding method for source, as exported by binder
function Wide_Expanded_Name (T : Tag) return Wide_String is
begin
return String_To_Wide_String
(Expanded_Name (T), Get_WC_Encoding_Method (WC_Encoding));
end Wide_Expanded_Name;
-----------------------------
-- Wide_Wide_Expanded_Name --
-----------------------------
function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is
begin
return String_To_Wide_Wide_String
(Expanded_Name (T), Get_WC_Encoding_Method (WC_Encoding));
end Wide_Wide_Expanded_Name;
end Ada.Tags;