2007-04-20 Javier Miranda <miranda@adacore.com>

	* a-tags.ads, a-tags.adb (Tag_Size): This constant is now internal to
	the package.
	(Object_Specific_Data_Array): This is now internal to the package.
	(Object_Specific_Data): This is now internal to the package.
	(Select_Specific_Data_Element): This is now internal to the package.
	(Select_Specific_Data_Array): This is now internal to the package.
	(Select_Specific_Data): This is now internal to the package.
	(Offset_To_Top_Function_Ptr): This is now public.
	(To_Offset_To_Top_Function_Ptr): Removed.
	(Storage_Offset_Ptr,To_Storage_Offset_Ptr): These declarations are now
	 local to subprogram Offset_To_Top.
	(Predefined_DT): Removed.
	(Typeinfo_Ptr): Removed.
	(OSD): This function is now internal to this package.
	(SSD): This function is now internal to this package.
	(DT): New function that displaces the pointer to the table of primitives
	 to get access to the enclosing wrapper record.
	(IW_Membership): Code cleanup.
	(Offset_To_Top): Code cleanup.
	(Predefined_DT): Removed.
	(Register_Interface_Tag): Removed.
	(Set_Interface_Table): Removed.
	(Set_Offset_Index): Removed.
	(Set_Offset_To_Top): Code cleanup.
	(Set_OSD): Removed.
	(Set_Signature): Removed.
	(Set_SSD): Removed.
	(Set_Tagged_Kind): Removed.
	(Typeinfo_Ptr): Removed.
	(TSD): Removed.
	(Displace): Add missing check on null actual.

	* exp_disp.ads, exp_disp.adb
	(Select_Expansion_Utilities): Removed.
	(Build_Common_Dispatching_Select_Statements): Moved to exp_atags.
	(Expand_Dispatching_Call): Update calls to Get_Prim_Op_Address because
	the interface requires a new parameter.
	(Make_Disp_Asynchronous_Select_Spec, Make_Disp_Conditional_Select_Spec,
	Make_Disp_Get_Prim_Op_Kind_Spec, Make_Disp_Timed_Select_Spec): Replace
	calls to subprograms Build_T, Build_S, etc. by the corresponding code.
	Done to remove package Select_Expansion_Utilities.
	(Make_DT): New implementation for statically allocated dispatch tables.
	(Make_Secondary_DT): Moved to the scope of Make_DT.
	(Register_Primitive): Code cleanup plus incoporate the use of the new
	function DT_Address_Attribute.
	(Expand_Interface_Thunk): The profile of this subprogram has been
	changed to return the Thunk_Id and the corresponding code.
	(Fill_DT_Entry): Removed. Its functionality is now provided by
	subprogram Register_Primitive.
	(Fill_Secondary_DT_Entry): Removed. Its functionality is now provided by
	subprogram Register_Primitive.
	(Register_Primitive): New subprogram that incorporates the previous
	functionalities of Fill_DT_Entry and Fill_Secondary_DT_Entry.
	(Build_Common_Dispatching_Select_Statements): Remove formal Typ. This
	was only required to call Make_DT_Access_Action, which is now removed.
	(Ada_Actions): Removed
	(Action_Is_Proc): Removed
	(Action_Nb_Arg): Removed
	Replace all the calls to Make_DT_Access_Action by direct calls to
	Make_Procedure_Call_Statement or Make_Function_Call.
	(Set_DTC_Entity_Value): New subprogram.
	(Set_All_DT_Position): Add call to new subprogram Set_DTC_Entity_Value.
	(Expand_Interface_Thunk): Add missing support for primitives that are
	functions with a controlling result (case in which there is no need
	to generate the thunk).

	* exp_atag.ads, exp_atag.adb
	(Build_DT): New subprogram that displaces the pointer to reference the
	base of the wrapper record.
	(Build_Typeinfo_Offset): Removed.
	(RTE_Tag_Node): Removed.
	(Build_Common_Dispatching_Select_Statements): Moved here from exp_disp
	(Build_Get_RC_Offset): Removed.
	(Build_Inherit_Predefined_Prims): Removed.
	(Build_Inherit_TSD: Removed.
	(Build_New_TSD): Removed.
	(Build_Set_External_Tag): Removed.
	(Build_Set_Predefined_Prim_Op_Address): Add documentation.
	(Build_Set_Prim_Op_Address): Add documentation.
	(Build_Set_TSD): Removed.

	* rtsfind.ads, rtsfind.adb
	(Load_Fail): If load fails and we are not in configurable run-time
	mode, then raise Unrecoverable_Error.
	(Text_IO_Kludge): Generate an error message if a run-time library is
	not available in a given run-time (ie. zfp run-time).
	(RTE_Record_Component): Add code to check that the component we search
	for is not found in two records in the given run-time package.
	(RE_DT_Offset_To_Top_Size, RE_DT_Predef_Prims_Size): Removed
	(RE_DT_Predef_Prims_Offset): New entity
	(RE_Static_Offset_To_Top): New entity
	(RE_HT_Link): New entity.
	(System_Address_Image): Addition of this run-time package.
	(RE_Address_Image): New entity.
	(RE_Abstract_Interface): Removed.
	(RE_Default_Prim_Op_Count): Removed.
	(RE_DT_Entry_Size): Removed.
	(RE_DT_Min_Prologue_Size): Removed.
	(RE_DT_Prologue_Size): Removed.
	(RE_Ifaces_Table_Ptr): Removed.
	(RE_Interface_Data_Ptr): Removed.
	(RE_Type_Specific_Data): Removed.
	(RE_Primary_DT): Removed.
	(RE_Register_Interface_Tag): Removed.
	(RE_Set_Offset_Index): Removed.
	(RE_Set_OSD): Removed.
	(RE_Set_SSD): Removed.
	(RE_Set_Signature): Removed.
	(RE_Set_Tagged_Kind): Removed.
	(RE_Address_Array): New entity.
	(RE_DT): New entity.
	(RE_Iface_Tag): New entity.
	(RE_Interfaces_Table): New entity.
	(RE_No_Dispatch_Table): New entity.
	(RE_NDT_Prims_Ptr): New entity.
	(RE_NDT_TSD): New entity.
	(RE_Num_Prims): New entity.
	(RE_Offset_To_Top_Function_Ptr): New entity.
	(RE_OSD_Table): New entity.
	(RE_OSD_Num_Prims): New entity.
	(RE_Predef_Prims): New entity
	(RE_Predef_Prims_Table_Ptr): New entity.
	(RE_Primary_DT): New entity.
	(RE_Signature): New entity.
	(RE_SSD): New entity.
	(RE_TSD): New entity.
	(RE_Type_Specific_Data): New entity.
	(RE_Tag_Kind): New entity.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@125379 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 318 insertions, 335 deletions

diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb
index 556265ac2fa..622087a08ad 100644
--- a/gcc/ada/a-tags.adb
+++ b/gcc/ada/a-tags.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -41,32 +41,40 @@ pragma Elaborate_All (System.HTable);
 
 package body Ada.Tags is
 
-   --  Object specific data types (see description in a-tags.ads)
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
+   --  Given the tag of an object and the tag associated to a type, return
+   --  true if Obj is in Typ'Class.
 
-   type Object_Specific_Data_Array is array (Positive range <>) of Positive;
+   function Get_External_Tag (T : Tag) return System.Address;
+   --  Returns address of a null terminated string containing the external name
 
-   type Object_Specific_Data (Nb_Prim : Positive) is record
-      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;
+   function Is_Primary_DT (T : Tag) return Boolean;
+   --  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.
 
-   --  Select specific data types
+   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).
 
-   type Select_Specific_Data_Element is record
-      Index : Positive;
-      Kind  : Prim_Op_Kind;
-   end record;
+   function OSD (T : Tag) return Object_Specific_Data_Ptr;
+   --  Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table,
+   --  retrieve the address of the record containing the Object Specific
+   --  Data table.
 
-   type Select_Specific_Data_Array is
-     array (Positive range <>) of Select_Specific_Data_Element;
+   function SSD (T : Tag) return Select_Specific_Data_Ptr;
+   --  Ada 2005 (AI-251): Given a pointer T to a dispatch Table, retrieves the
+   --  address of the record containing the Select Specific Data in T's TSD.
 
-   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;
+   pragma Inline_Always (CW_Membership);
+   pragma Inline_Always (Get_External_Tag);
+   pragma Inline_Always (Is_Primary_DT);
+   pragma Inline_Always (OSD);
+   pragma Inline_Always (SSD);
 
    ---------------------------------------------
    -- Unchecked Conversions for String Fields --
@@ -78,6 +86,17 @@ package body Ada.Tags is
    function To_Cstring_Ptr is
      new Unchecked_Conversion (System.Address, Cstring_Ptr);
 
+   --  Disable warnings on possible aliasing problem because we only use
+   --  use this function to convert tags found in the External_Tag of
+   --  locally defined tagged types.
+
+   pragma Warnings (off);
+
+   function To_Tag is
+     new Unchecked_Conversion (Integer_Address, Tag);
+
+   pragma Warnings (on);
+
    ------------------------------------------------
    -- Unchecked Conversions for other components --
    ------------------------------------------------
@@ -88,47 +107,93 @@ package body Ada.Tags is
    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.
+   -------------------------------
+   -- Inline_Always Subprograms --
+   -------------------------------
 
-   function To_Offset_To_Top_Function_Ptr is
-      new Unchecked_Conversion (System.Address, Offset_To_Top_Function_Ptr);
+   --  Inline_always subprograms must be placed before their first call to
+   --  avoid defeating the frontend inlining mechanism and thus ensure the
+   --  generation of their correct debug info.
 
-   type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset;
+   -------------------
+   -- CW_Membership --
+   -------------------
 
-   function To_Storage_Offset_Ptr is
-     new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
+   --  Canonical implementation of Classwide Membership corresponding to:
 
-   -----------------------
-   -- Local Subprograms --
-   -----------------------
+   --     Obj in Typ'Class
 
-   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.
+   --  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".
 
-   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).
+   --  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:
+
+   --   TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
+   --     = Typ'tag
+
+   function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
+      Obj_TSD_Ptr : constant Addr_Ptr :=
+                     To_Addr_Ptr (To_Address (Obj_Tag) - DT_Typeinfo_Ptr_Size);
+      Typ_TSD_Ptr : constant Addr_Ptr :=
+                     To_Addr_Ptr (To_Address (Typ_Tag) - DT_Typeinfo_Ptr_Size);
+      Obj_TSD     : constant Type_Specific_Data_Ptr :=
+                     To_Type_Specific_Data_Ptr (Obj_TSD_Ptr.all);
+      Typ_TSD     : constant Type_Specific_Data_Ptr :=
+                     To_Type_Specific_Data_Ptr (Typ_TSD_Ptr.all);
+      Pos         : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth;
+   begin
+      return Pos >= 0 and then Obj_TSD.Tags_Table (Pos) = Typ_Tag;
+   end CW_Membership;
+
+   ----------------------
+   -- Get_External_Tag --
+   ----------------------
 
-   function Predefined_DT (T : Tag) return Tag;
-   pragma Inline_Always (Predefined_DT);
-   --  Displace the Tag to reference the dispatch table containing the
-   --  predefined primitives.
+   function Get_External_Tag (T : Tag) return System.Address is
+      TSD_Ptr : constant Addr_Ptr :=
+                  To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
+      TSD     : constant Type_Specific_Data_Ptr :=
+                  To_Type_Specific_Data_Ptr (TSD_Ptr.all);
+   begin
+      return To_Address (TSD.External_Tag);
+   end Get_External_Tag;
 
-   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.
+   -------------------
+   -- Is_Primary_DT --
+   -------------------
 
-   pragma Unreferenced (Typeinfo_Ptr);
-   --  These functions will be used for full compatibility with the C++ ABI
+   function Is_Primary_DT (T : Tag) return Boolean is
+   begin
+      return DT (T).Signature = Primary_DT;
+   end Is_Primary_DT;
+
+   ---------
+   -- OSD --
+   ---------
+
+   function OSD (T : Tag) return Object_Specific_Data_Ptr is
+      OSD_Ptr : constant Addr_Ptr :=
+                  To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
+   begin
+      return To_Object_Specific_Data_Ptr (OSD_Ptr.all);
+   end OSD;
+
+   ---------
+   -- SSD --
+   ---------
+
+   function SSD (T : Tag) return Select_Specific_Data_Ptr is
+      TSD_Ptr : constant Addr_Ptr :=
+                  To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
+      TSD     : constant Type_Specific_Data_Ptr :=
+                  To_Type_Specific_Data_Ptr (TSD_Ptr.all);
+   begin
+      return TSD.SSD;
+   end SSD;
 
    -------------------------
    -- External_Tag_HTable --
@@ -192,8 +257,12 @@ package body Ada.Tags is
       -----------------
 
       function Get_HT_Link (T : Tag) return Tag is
+         TSD_Ptr : constant Addr_Ptr :=
+                     To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
+         TSD     : constant Type_Specific_Data_Ptr :=
+                     To_Type_Specific_Data_Ptr (TSD_Ptr.all);
       begin
-         return TSD (T).HT_Link;
+         return TSD.HT_Link;
       end Get_HT_Link;
 
       ----------
@@ -213,39 +282,16 @@ package body Ada.Tags is
       -----------------
 
       procedure Set_HT_Link (T : Tag; Next : Tag) is
+         TSD_Ptr : constant Addr_Ptr :=
+                     To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
+         TSD     : constant Type_Specific_Data_Ptr :=
+                     To_Type_Specific_Data_Ptr (TSD_Ptr.all);
       begin
-         TSD (T).HT_Link := Next;
+         TSD.HT_Link := Next;
       end Set_HT_Link;
 
    end HTable_Subprograms;
 
-   -------------------
-   -- 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:
-
-   --   TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
-   --     = Typ'tag
-
-   function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
-      Pos : Integer;
-   begin
-      Pos := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
-      return Pos >= 0 and then TSD (Obj_Tag).Tags_Table (Pos) = Typ_Tag;
-   end CW_Membership;
-
    ------------------
    -- Base_Address --
    ------------------
@@ -265,14 +311,18 @@ package body Ada.Tags is
    is
       Iface_Table : Interface_Data_Ptr;
       Obj_Base    : System.Address;
-      Obj_DT      : Tag;
-      Obj_TSD     : Type_Specific_Data_Ptr;
+      Obj_DT      : Dispatch_Table_Ptr;
+      Obj_DT_Tag  : Tag;
 
    begin
-      Obj_Base    := This - Offset_To_Top (This);
-      Obj_DT      := To_Tag_Ptr (Obj_Base).all;
-      Obj_TSD     := TSD (Obj_DT);
-      Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
+      if System."=" (This, System.Null_Address) then
+         return System.Null_Address;
+      end if;
+
+      Obj_Base    := Base_Address (This);
+      Obj_DT_Tag  := To_Tag_Ptr (Obj_Base).all;
+      Obj_DT      := DT (To_Tag_Ptr (Obj_Base).all);
+      Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table;
 
       if Iface_Table /= null then
          for Id in 1 .. Iface_Table.Nb_Ifaces loop
@@ -288,14 +338,11 @@ package body Ada.Tags is
                --  to provide us with this value
 
                else
-                  Obj_Base :=
-                    Obj_Base +
-                      To_Offset_To_Top_Function_Ptr
-                        (Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func).all
-                          (Obj_Base);
+                  Obj_Base := Obj_Base +
+                    Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func.all
+                      (Obj_Base);
                end if;
 
-               Obj_DT := To_Tag_Ptr (Obj_Base).all;
                return Obj_Base;
             end if;
          end loop;
@@ -304,7 +351,7 @@ package body Ada.Tags is
       --  Check if T is an immediate ancestor. This is required to handle
       --  conversion of class-wide interfaces to tagged types.
 
-      if CW_Membership (Obj_DT, T) then
+      if CW_Membership (Obj_DT_Tag, T) then
          return Obj_Base;
       end if;
 
@@ -313,6 +360,17 @@ package body Ada.Tags is
       raise Constraint_Error;
    end Displace;
 
+   --------
+   -- DT --
+   --------
+
+   function DT (T : Tag) return Dispatch_Table_Ptr is
+      Offset : constant SSE.Storage_Offset :=
+                 To_Dispatch_Table_Ptr (T).Prims_Ptr'Position;
+   begin
+      return To_Dispatch_Table_Ptr (To_Address (T) - Offset);
+   end DT;
+
    -------------------
    -- IW_Membership --
    -------------------
@@ -329,20 +387,15 @@ package body Ada.Tags is
 
    function IW_Membership (This : System.Address; T : Tag) return Boolean is
       Iface_Table : Interface_Data_Ptr;
-      Last_Id     : Natural;
       Obj_Base    : System.Address;
-      Obj_DT      : Tag;
+      Obj_DT      : Dispatch_Table_Ptr;
       Obj_TSD     : Type_Specific_Data_Ptr;
 
    begin
-      Obj_Base := This - Offset_To_Top (This);
-      Obj_DT   := To_Tag_Ptr (Obj_Base).all;
-      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);
+      Obj_Base    := Base_Address (This);
+      Obj_DT      := DT (To_Tag_Ptr (Obj_Base).all);
+      Obj_TSD     := To_Type_Specific_Data_Ptr (Obj_DT.TSD);
+      Iface_Table := Obj_TSD.Interfaces_Table;
 
       if Iface_Table /= null then
          for Id in 1 .. Iface_Table.Nb_Ifaces loop
@@ -355,7 +408,7 @@ package body Ada.Tags is
       --  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
+      for Id in 0 .. Obj_TSD.Idepth loop
          if Obj_TSD.Tags_Table (Id) = T then
             return True;
          end if;
@@ -384,14 +437,18 @@ package body Ada.Tags is
    -------------------
 
    function Expanded_Name (T : Tag) return String is
-      Result : Cstring_Ptr;
+      Result  : Cstring_Ptr;
+      TSD_Ptr : Addr_Ptr;
+      TSD     : Type_Specific_Data_Ptr;
 
    begin
       if T = No_Tag then
          raise Tag_Error;
       end if;
 
-      Result := TSD (T).Expanded_Name;
+      TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
+      TSD     := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
+      Result  := TSD.Expanded_Name;
       return Result (1 .. Length (Result));
    end Expanded_Name;
 
@@ -400,14 +457,18 @@ package body Ada.Tags is
    ------------------
 
    function External_Tag (T : Tag) return String is
-      Result : Cstring_Ptr;
+      Result  : Cstring_Ptr;
+      TSD_Ptr : Addr_Ptr;
+      TSD     : Type_Specific_Data_Ptr;
 
    begin
       if T = No_Tag then
          raise Tag_Error;
       end if;
 
-      Result := TSD (T).External_Tag;
+      TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
+      TSD     := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
+      Result  := TSD.External_Tag;
       return Result (1 .. Length (Result));
    end External_Tag;
 
@@ -421,15 +482,6 @@ package body Ada.Tags is
    end Get_Entry_Index;
 
    ----------------------
-   -- Get_External_Tag --
-   ----------------------
-
-   function Get_External_Tag (T : Tag) return System.Address is
-   begin
-      return To_Address (TSD (T).External_Tag);
-   end Get_External_Tag;
-
-   ----------------------
    -- Get_Prim_Op_Kind --
    ----------------------
 
@@ -462,8 +514,12 @@ package body Ada.Tags is
    -------------------
 
    function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is
+      TSD_Ptr : constant Addr_Ptr :=
+                  To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
+      TSD     : constant Type_Specific_Data_Ptr :=
+                  To_Type_Specific_Data_Ptr (TSD_Ptr.all);
    begin
-      return TSD (T).RC_Offset;
+      return TSD.RC_Offset;
    end Get_RC_Offset;
 
    ---------------------
@@ -471,10 +527,8 @@ package body Ada.Tags is
    ---------------------
 
    function Get_Tagged_Kind (T : Tag) return Tagged_Kind is
-      Tagged_Kind_Ptr : constant System.Address :=
-                          To_Address (T) - K_Tagged_Kind;
    begin
-      return To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all;
+      return DT (T).Tag_Kind;
    end Get_Tagged_Kind;
 
    -----------------------------
@@ -482,11 +536,13 @@ package body Ada.Tags is
    -----------------------------
 
    function Interface_Ancestor_Tags (T : Tag) return Tag_Array is
-      Iface_Table : Interface_Data_Ptr;
+      TSD_Ptr     : constant Addr_Ptr :=
+                      To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
+      TSD         : constant Type_Specific_Data_Ptr :=
+                      To_Type_Specific_Data_Ptr (TSD_Ptr.all);
+      Iface_Table : constant Interface_Data_Ptr := TSD.Interfaces_Table;
 
    begin
-      Iface_Table := To_Interface_Data_Ptr (TSD (T).Ifaces_Table_Ptr);
-
       if Iface_Table = null then
          declare
             Table : Tag_Array (1 .. 0);
@@ -510,17 +566,67 @@ package body Ada.Tags is
    -- Internal_Tag --
    ------------------
 
+   --  Internal tags have the following format:
+   --    "Internal tag at 16#ADDRESS#: <full-name-of-tagged-type>"
+
+   Internal_Tag_Header : constant String    := "Internal tag at ";
+   Header_Separator    : constant Character := '#';
+
    function Internal_Tag (External : String) return Tag is
       Ext_Copy : aliased String (External'First .. External'Last + 1);
-      Res      : Tag;
+      Res      : Tag := null;
 
    begin
-      --  Make a copy of the string representing the external tag with
-      --  a null at the end.
+      --  Handle locally defined tagged types
+
+      if External'Length > Internal_Tag_Header'Length
+        and then
+         External (External'First ..
+                     External'First + Internal_Tag_Header'Length - 1)
+           = Internal_Tag_Header
+      then
+         declare
+            Addr_First : constant Natural :=
+                           External'First + Internal_Tag_Header'Length;
+            Addr_Last  : Natural;
+            Addr       : Integer_Address;
+
+         begin
+            --  Search the second separator (#) to identify the address
+
+            Addr_Last := Addr_First;
+
+            for J in 1 .. 2 loop
+               while Addr_Last <= External'Last
+                 and then External (Addr_Last) /= Header_Separator
+               loop
+                  Addr_Last := Addr_Last + 1;
+               end loop;
+
+               --  Skip the first separator
+
+               if J = 1 then
+                  Addr_Last := Addr_Last + 1;
+               end if;
+            end loop;
+
+            if Addr_Last <= External'Last then
+               Addr :=
+                 Integer_Address'Value (External (Addr_First .. Addr_Last));
+               return To_Tag (Addr);
+            end if;
+         end;
+
+      --  Handle library-level tagged types
+
+      else
+         --  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);
+         Ext_Copy (External'Range) := External;
+         Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
+         Res := External_Tag_HTable.Get (Ext_Copy'Address);
+      end if;
 
       if Res = null then
          declare
@@ -546,32 +652,30 @@ package body Ada.Tags is
      (Descendant : Tag;
       Ancestor   : Tag) return Boolean
    is
+      D_TSD_Ptr : constant Addr_Ptr :=
+                    To_Addr_Ptr (To_Address (Descendant)
+                                   - DT_Typeinfo_Ptr_Size);
+      A_TSD_Ptr : constant Addr_Ptr :=
+                    To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size);
+      D_TSD     : constant Type_Specific_Data_Ptr :=
+                    To_Type_Specific_Data_Ptr (D_TSD_Ptr.all);
+      A_TSD     : constant Type_Specific_Data_Ptr :=
+                    To_Type_Specific_Data_Ptr (A_TSD_Ptr.all);
+
    begin
       return CW_Membership (Descendant, Ancestor)
-        and then TSD (Descendant).Access_Level = TSD (Ancestor).Access_Level;
+        and then D_TSD.Access_Level = A_TSD.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;
+      Len : Integer;
 
    begin
+      Len := 1;
       while Str (Len) /= ASCII.Nul loop
          Len := Len + 1;
       end loop;
@@ -584,31 +688,26 @@ package body Ada.Tags is
    -------------------
 
    function Offset_To_Top
-     (This : System.Address) return System.Storage_Elements.Storage_Offset
+     (This : System.Address) return SSE.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;
+      Tag_Size : constant SSE.Storage_Count :=
+        SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
 
-      return Offset_To_Top.all;
-   end Offset_To_Top;
+      type Storage_Offset_Ptr is access SSE.Storage_Offset;
+      function To_Storage_Offset_Ptr is
+        new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
 
-   ---------
-   -- OSD --
-   ---------
+      Curr_DT : Dispatch_Table_Ptr;
 
-   function OSD (T : Tag) return Object_Specific_Data_Ptr is
-      OSD_Ptr : constant Addr_Ptr :=
-                  To_Addr_Ptr (To_Address (T) - K_Typeinfo);
    begin
-      return To_Object_Specific_Data_Ptr (OSD_Ptr.all);
-   end OSD;
+      Curr_DT := DT (To_Tag_Ptr (This).all);
+
+      if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then
+         return To_Storage_Offset_Ptr (This + Tag_Size).all;
+      else
+         return Curr_DT.Offset_To_Top;
+      end if;
+   end Offset_To_Top;
 
    -----------------
    -- Parent_Size --
@@ -626,16 +725,28 @@ package body Ada.Tags is
       --  The pointer to the _size primitive is always in the first slot of
       --  the dispatch table.
 
-      Parent_Tag : Tag;
-      --  The tag of the parent type through the dispatch table
-
-      F : Acc_Size;
+      TSD_Ptr : constant Addr_Ptr :=
+                  To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
+      TSD     : constant Type_Specific_Data_Ptr :=
+                  To_Type_Specific_Data_Ptr (TSD_Ptr.all);
+      --  Pointer to the TSD
+
+      Parent_Tag              : constant Tag := TSD.Tags_Table (Parent_Slot);
+      Parent_Predef_Prims_Ptr : constant Addr_Ptr :=
+                                  To_Addr_Ptr (To_Address (Parent_Tag)
+                                                - DT_Predef_Prims_Offset);
+      Parent_Predef_Prims     : constant Predef_Prims_Table_Ptr :=
+                                  To_Predef_Prims_Table_Ptr
+                                    (Parent_Predef_Prims_Ptr.all);
+
+      --  The tag of the parent type through the dispatch table and its
+      --  Predef_Prims field.
+
+      F : constant Acc_Size :=
+            To_Acc_Size (Parent_Predef_Prims (Size_Slot));
       --  Access to the _size primitive of the parent
 
    begin
-      Parent_Tag := TSD (T).Tags_Table (Parent_Slot);
-      F := To_Acc_Size (Predefined_DT (Parent_Tag).Prims_Ptr (Size_Slot));
-
       --  Here we compute the size of the _parent field of the object
 
       return SSE.Storage_Count (F.all (Obj));
@@ -646,50 +757,29 @@ package body Ada.Tags is
    ----------------
 
    function Parent_Tag (T : Tag) return Tag is
+      TSD_Ptr : Addr_Ptr;
+      TSD     : Type_Specific_Data_Ptr;
+
    begin
       if T = No_Tag then
          raise Tag_Error;
       end if;
 
+      TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
+      TSD     := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
+
       --  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
+      if TSD.Idepth = 0 then
          return No_Tag;
       else
-         return TSD (T).Tags_Table (1);
+         return TSD.Tags_Table (1);
       end if;
    end Parent_Tag;
 
-   -------------------
-   -- Predefined_DT --
-   -------------------
-
-   function Predefined_DT (T : Tag) return Tag is
-   begin
-      return To_Tag (To_Address (T) - DT_Prologue_Size);
-   end Predefined_DT;
-
-   ----------------------------
-   -- 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
-      New_T_TSD   := TSD (T);
-      Iface_Table := To_Interface_Data_Ptr (New_T_TSD.Ifaces_Table_Ptr);
-      Iface_Table.Ifaces_Table (Position).Iface_Tag := Interface_T;
-   end Register_Interface_Tag;
-
    ------------------
    -- Register_Tag --
    ------------------
@@ -712,86 +802,54 @@ package body Ada.Tags is
       SSD (T).SSD_Table (Position).Index := Value;
    end Set_Entry_Index;
 
-   -------------------------
-   -- Set_Interface_Table --
-   -------------------------
-
-   procedure Set_Interface_Table (T : Tag; Value : System.Address) is
-   begin
-      TSD (T).Ifaces_Table_Ptr := Value;
-   end Set_Interface_Table;
-
-   ----------------------
-   -- Set_Offset_Index --
-   ----------------------
-
-   procedure Set_Offset_Index
-     (T        : Tag;
-      Position : Positive;
-      Value    : Positive)
-   is
-   begin
-      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)
+     (This         : System.Address;
+      Interface_T  : Tag;
+      Is_Static    : Boolean;
+      Offset_Value : SSE.Storage_Offset;
+      Offset_Func  : Offset_To_Top_Function_Ptr)
    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
-         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;
+      Prim_DT     : Dispatch_Table_Ptr;
+      Sec_Base    : System.Address;
+      Sec_DT      : Dispatch_Table_Ptr;
+      Iface_Table : Interface_Data_Ptr;
 
-      --  Save the offset to top field in the secondary dispatch table.
+   begin
+      --  Save the offset to top field in the secondary dispatch table
 
       if Offset_Value /= 0 then
          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);
+         Sec_DT   := DT (To_Tag_Ptr (Sec_Base).all);
 
          if Is_Static then
-            Offset_To_Top.all := Offset_Value;
+            Sec_DT.Offset_To_Top := Offset_Value;
          else
-            Offset_To_Top.all := SSE.Storage_Offset'Last;
+            Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last;
          end if;
       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.
+      --  "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     := DT (To_Tag_Ptr (This).all);
+      Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
 
-      Obj_TSD     := TSD (Prim_DT);
-      Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
+      --  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.
 
       --  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.Ifaces_Table (Id).Iface_Tag = Interface_T then
-               Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := Is_Static;
+               Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top :=
+                 Is_Static;
 
                if Is_Static then
                   Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value
@@ -811,17 +869,6 @@ package body Ada.Tags is
       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
-      OSD_Ptr.all := Value;
-   end Set_OSD;
-
    ----------------------
    -- Set_Prim_Op_Kind --
    ----------------------
@@ -835,70 +882,6 @@ package body Ada.Tags is
       SSD (T).SSD_Table (Position).Kind := Value;
    end Set_Prim_Op_Kind;
 
-   -------------------
-   -- 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
-      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
-      To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all := Value;
-   end Set_Tagged_Kind;
-
-   ---------
-   -- SSD --
-   ---------
-
-   function SSD (T : Tag) return Select_Specific_Data_Ptr is
-   begin
-      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
-      return To_Type_Specific_Data_Ptr (TSD_Ptr.all);
-   end TSD;
-
    ------------------------
    -- Wide_Expanded_Name --
    ------------------------