------------------------------------------------------------------------------
--                                                                          --
--                         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;