------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUNTIME COMPONENTS                          --
--                                                                          --
--                             A D A . T A G S                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.9 $                              --
--                                                                          --
--           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
--                                                                          --
-- The GNAT library is free software; you can redistribute it and/or modify --
-- it under terms of the GNU Library General Public License as published by --
-- the Free Software  Foundation; either version 2, or (at your option) any --
-- later version.  The GNAT library is distributed in the hope that it will --
-- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
-- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
-- Library  General  Public  License for  more  details.  You  should  have --
-- received  a copy of the GNU  Library  General Public License  along with --
-- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
-- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
--                                                                          --
------------------------------------------------------------------------------

with Unchecked_Conversion;
package body Ada.Tags is

   type Dispatch_Table is record
      Idepth : Natural;
      Tags   : System.Address;
      Fptrs  : Address_Array (Positive);
   end record;

   subtype Big_Address_Array is Address_Array (Natural);
   type Address_Array_Ptr is access all Big_Address_Array;

   function To_Address_Array_Ptr is
     new Unchecked_Conversion (System.Address, Address_Array_Ptr);

   function To_Address is new Unchecked_Conversion (Tag, System.Address);

   -------------------
   -- Expanded_Name --
   -------------------

   function Expanded_Name (T : Tag) return String is
   begin
      raise Program_Error; -- TBSL ???
      return "";
   end Expanded_Name;

   ------------------
   -- External_Tag --
   ------------------

   function External_Tag (T : Tag) return String is
   begin
      raise Program_Error; -- TBSL  ???
      return "";
   end External_Tag;

   ------------------
   -- Internal_Tag --
   ------------------

   function Internal_Tag (External : String) return Tag is
   begin
      raise Program_Error; -- TBSL  ???
      return null;
   end Internal_Tag;

   -------------------------
   -- Set_Prim_Op_Address --
   -------------------------

   procedure Set_Prim_Op_Address
     (DTptr    : Tag;
      Position : Positive;
      Value    : System.Address)
   is
   begin
      DTptr.Fptrs (Position) := Value;
   end Set_Prim_Op_Address;

   -------------------------
   -- Get_Prim_Op_Address --
   -------------------------

   function Get_Prim_Op_Address
     (DTptr    : Tag;
      Position : Positive)
     return      System.Address
   is
   begin
      return DTptr.Fptrs (Position);
   end Get_Prim_Op_Address;

   ---------------------------
   -- Set_Inheritance_Depth --
   ---------------------------

   procedure Set_Inheritance_Depth
     (DTptr : Tag;
      Value : Natural)
   is
   begin
      DTptr.Idepth := Value;
   end Set_Inheritance_Depth;

   ---------------------------
   -- Set_Inheritance_Depth --
   ---------------------------

   function Get_Inheritance_Depth (DTptr : Tag) return Natural is
   begin
      return DTptr.Idepth;
   end Get_Inheritance_Depth;

   -------------------------
   -- Set_Ancestor_DTptrs --
   -------------------------

   procedure Set_Ancestor_Tags (DTptr : Tag; Value : System.Address) is
   begin
      DTptr.Tags := Value;
   end Set_Ancestor_Tags;

   -----------------------
   -- Get_Ancestor_Tags --
   -----------------------

   function Get_Ancestor_Tags  (DTptr : Tag) return System.Address is
   begin
      return DTptr.Tags;
   end Get_Ancestor_Tags;

   -------------
   -- DT_Size --
   -------------

   function DT_Size
     (Entry_Count : Natural)
      return        System.Storage_Elements.Storage_Count
   is
      type DT is record
         Idepth : Natural;
         Tags   : System.Address;
         Fptrs  : Address_Array (1 .. Entry_Count);
      end record;

   begin
      return (DT'Size + System.Storage_Unit - 1) / System.Storage_Unit;
   end DT_Size;

   ----------------
   -- Inherit_DT --
   ----------------

   procedure Inherit_DT
    (Old_DTptr   : Tag;
     New_DTptr   : Tag;
     Entry_Count : Natural)
   is
   begin
      --  Inherit primitive operations

      New_DTptr.Fptrs (1 .. Entry_Count) := Old_DTptr.Fptrs (1 .. Entry_Count);

      --  The inheritance depth is incremented

      New_DTptr.Idepth := Old_DTptr.Idepth + 1;

      --  The Ancestor Tags Table is also inherited (with a shift)

      To_Address_Array_Ptr (New_DTptr.Tags) (1 .. New_DTptr.Idepth)
        := To_Address_Array_Ptr (Old_DTptr.Tags) (0 .. Old_DTptr.Idepth);

      To_Address_Array_Ptr (New_DTptr.Tags) (0) := To_Address (New_DTptr);
   end Inherit_DT;

   --------------------
   --  CW_Membership --
   --------------------

   --  Canonical implementation of Classwide Membership corresponding to:

   --     Obj in Typ'Class

   --  Each dispatch table contains a reference to a table of ancestors
   --  (Tags) and a count of the level of inheritance (Idepth). Obj is in
   --  Typ'Class if Typ'Tag is in the table of ancestors 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.Tags (Obj'tag.Idepth - Typ'tag.Idepth) = Typ'tag

   function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
      Pos : constant Integer := Obj_Tag.Idepth - Typ_Tag.Idepth;

   begin
      return Pos >= 0 and then
        To_Address_Array_Ptr (Obj_Tag.Tags) (Pos) = To_Address (Typ_Tag);
   end CW_Membership;
end Ada.Tags;
