------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUNTIME COMPONENTS                          --
--                                                                          --
--                             A D A . T A G S                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.16 $                             --
--                                                                          --
--     Copyright (C) 1992,1993,1994,1995 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,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, 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. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
--                                                                          --
------------------------------------------------------------------------------

with Unchecked_Conversion;
with GNAT.Htable;

package body Ada.Tags is

--  Structure of the GNAT Dispatch Table

--   +----------------------+
--   |      TSD pointer  ---|-----> Type Specific Data
--   +----------------------+       +-------------------+
--   | table of             |       | inheritance depth |
--   :   primitive ops      :       +-------------------+
--   |     pointers         |       |   expanded name   |
--   +----------------------+       +-------------------+
--                                  |   external tag    |
--                                  +-------------------+
--                                  |   Hash table link |
--                                  +-------------------+
--                                  | table of          |
--                                  :   ancestor        :
--                                  |      tags         |
--                                  +-------------------+

   use System;


   subtype Cstring is String (Positive);
   type Cstring_Ptr is access all Cstring;
   type Tag_Table is array (Natural range <>) of Tag;

   type Type_Specific_Data is record
      Idepth        : Natural;
      Expanded_Name : Cstring_Ptr;
      External_Tag  : Cstring_Ptr;
      HT_Link       : Tag;
      Ancestor_Tags : Tag_Table (Natural);
   end record;

   type Dispatch_Table is record
      TSD       : Type_Specific_Data_Ptr;
      Prims_Ptr : Address_Array (Positive);
   end record;

   -------------------------------------------
   -- Unchecked Conversions for Tag and TSD --
   -------------------------------------------

   function To_Type_Specific_Data_Ptr is
     new Unchecked_Conversion (Address, Type_Specific_Data_Ptr);

   function To_Address is new Unchecked_Conversion (Tag, Address);
   function To_Address is
     new Unchecked_Conversion (Type_Specific_Data_Ptr, Address);

   ---------------------------------------------
   -- Unchecked Conversions for String Fields --
   ---------------------------------------------

   function To_Cstring_Ptr is
     new Unchecked_Conversion (Address, Cstring_Ptr);

   function To_Address is
     new Unchecked_Conversion (Cstring_Ptr, Address);

   -----------------------
   -- Local Subprograms --
   -----------------------

   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).

   -------------------------
   -- External_Tag_Htable --
   -------------------------

   type Htable_Headers is range 1 .. 64;

   procedure Set_HT_Link (T : Tag; Next : Tag);
   function  Get_HT_Link (T : Tag) return Tag;

   function Hash (F : Address) return Htable_Headers;
   function Equal (A, B : Address) return Boolean;

   package External_Tag_Htable is new GNAT.Htable.Static_Htable (
     Header_Num => Htable_Headers,
     Element    => Dispatch_Table,
     Elmt_Ptr   => Tag,
     Set_Next   => Set_HT_Link,
     Next       => Get_HT_Link,
     Key        => Address,
     Get_Key    => Get_External_Tag,
     Hash       => Hash,
     Equal      => Equal);

   --  Subprograms for above instantiation

   function Equal (A, B : Address) return Boolean is
      Str1 : Cstring_Ptr := To_Cstring_Ptr (A);
      Str2 : 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;

   function Get_HT_Link (T : Tag) return Tag is
   begin
      return T.TSD.HT_Link;
   end Get_HT_Link;

   function Hash (F : Address) return Htable_Headers is
      function H is new GNAT.Htable.Hash (Htable_Headers);
      Str : Cstring_Ptr := To_Cstring_Ptr (F);
      Res : constant Htable_Headers := H (Str (1 .. Length (Str)));

   begin
      return Res;
   end Hash;

   procedure Set_HT_Link (T : Tag; Next : Tag) is
   begin
      T.TSD.HT_Link := Next;
   end Set_HT_Link;

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

   procedure Inherit_DT
    (Old_T   : Tag;
     New_T   : Tag;
     Entry_Count : Natural)
   is
   begin
      if Old_T /= null then
         New_T.Prims_Ptr (1 .. Entry_Count) :=
           Old_T.Prims_Ptr (1 .. Entry_Count);
      end if;
   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
   --  (Ancestor_Tags) 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 : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth;

   begin
      return Pos >= 0 and then Obj_Tag.TSD.Ancestor_Tags (Pos) = Typ_Tag;
   end CW_Membership;

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

   function Expanded_Name (T : Tag) return String is
      Result : Cstring_Ptr := T.TSD.Expanded_Name;

   begin
      return Result (1 .. Length (Result));
   end Expanded_Name;

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

   function External_Tag (T : Tag) return String is
      Result : Cstring_Ptr := T.TSD.External_Tag;

   begin
      return Result (1 .. Length (Result));
   end External_Tag;

   -----------------------
   -- Get_Expanded_Name --
   -----------------------

   function Get_Expanded_Name (T : Tag) return Address is
   begin
      return To_Address (T.TSD.Expanded_Name);
   end Get_Expanded_Name;

   ----------------------
   -- Get_External_Tag --
   ----------------------

   function Get_External_Tag (T : Tag) return Address is
   begin
      return To_Address (T.TSD.External_Tag);
   end Get_External_Tag;

   ---------------------------
   -- Get_Inheritance_Depth --
   ---------------------------

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

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

   function Get_Prim_Op_Address
     (T        : Tag;
      Position : Positive)
      return     Address
   is
   begin
      return T.Prims_Ptr (Position);
   end Get_Prim_Op_Address;

   -------------
   -- Get_TSD --
   -------------

   function Get_TSD  (T : Tag) return Address is
   begin
      return To_Address (T.TSD);
   end Get_TSD;

   -----------------
   -- Inherit_TSD --
   -----------------

   procedure Inherit_TSD (Old_TSD : Address; New_Tag : Tag) is
      TSD     : constant Type_Specific_Data_Ptr :=
                  To_Type_Specific_Data_Ptr (Old_TSD);
      New_TSD : Type_Specific_Data renames New_Tag.TSD.all;

   begin
      if TSD /= null then
         New_TSD.Idepth := TSD.Idepth + 1;
         New_TSD.Ancestor_Tags (1 .. New_TSD.Idepth)
                            := TSD.Ancestor_Tags (0 .. TSD.Idepth);
      else
         New_TSD.Idepth := 0;
      end if;

      New_TSD.Ancestor_Tags (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
         raise Tag_Error;
      end if;

      return Res;
   end Internal_Tag;

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

   ------------------
   -- Register_Tag --
   ------------------

   procedure Register_Tag (T : Tag) is
   begin
      External_Tag_Htable.Set (T);
   end Register_Tag;

   -----------------------
   -- Set_Expanded_Name --
   -----------------------

   procedure Set_Expanded_Name (T : Tag; Value : Address) is
   begin
      T.TSD.Expanded_Name := To_Cstring_Ptr (Value);
   end Set_Expanded_Name;

   ----------------------
   -- Set_External_Tag --
   ----------------------

   procedure Set_External_Tag (T : Tag; Value : Address) is
   begin
      T.TSD.External_Tag := To_Cstring_Ptr (Value);
   end Set_External_Tag;

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

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

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

   procedure Set_Prim_Op_Address
     (T        : Tag;
      Position : Positive;
      Value    : Address)
   is
   begin
      T.Prims_Ptr (Position) := Value;
   end Set_Prim_Op_Address;

   -------------
   -- Set_TSD --
   -------------

   procedure Set_TSD (T : Tag; Value : Address) is
   begin
      T.TSD := To_Type_Specific_Data_Ptr (Value);
   end Set_TSD;

end Ada.Tags;
