--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/ada/libgnat/a-tags.adb	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,1112 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUN-TIME COMPONENTS                         --
+--                                                                          --
+--                             A D A . T A G S                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--          Copyright (C) 1992-2017, 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 3,  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.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- 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 Ada.Unchecked_Conversion;
+
+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 (System.HTable);
+--  Elaborate needed instead of Elaborate_All to avoid elaboration cycles
+--  when polling is turned on. This is safe because HTable doesn't do anything
+--  at elaboration time; it just contains a generic package we want to
+--  instantiate.
+
+package body Ada.Tags is
+
+   -----------------------
+   -- 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.
+
+   function Get_External_Tag (T : Tag) return System.Address;
+   --  Returns address of a null terminated string containing the external name
+
+   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.
+
+   function IW_Membership
+     (Descendant_TSD : Type_Specific_Data_Ptr;
+      T              : Tag) return Boolean;
+   --  Subsidiary function of IW_Membership and CW_Membership which factorizes
+   --  the functionality needed to check if a given descendant implements an
+   --  interface tag T.
+
+   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). See comment in body
+   --  explaining why we cannot use the normal strlen built-in.
+
+   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.
+
+   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.
+
+   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
+
+   function To_Address is
+     new Unchecked_Conversion (Cstring_Ptr, System.Address);
+
+   function To_Cstring_Ptr is
+     new Unchecked_Conversion (System.Address, Cstring_Ptr);
+
+   --  Disable warnings on possible aliasing problem
+
+   function To_Tag is
+     new Unchecked_Conversion (Integer_Address, Tag);
+
+   function To_Addr_Ptr is
+      new Ada.Unchecked_Conversion (System.Address, Addr_Ptr);
+
+   function To_Address is
+     new Ada.Unchecked_Conversion (Tag, System.Address);
+
+   function To_Dispatch_Table_Ptr is
+      new Ada.Unchecked_Conversion (Tag, Dispatch_Table_Ptr);
+
+   function To_Dispatch_Table_Ptr is
+      new Ada.Unchecked_Conversion (System.Address, Dispatch_Table_Ptr);
+
+   function To_Object_Specific_Data_Ptr is
+     new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr);
+
+   function To_Tag_Ptr is
+     new Ada.Unchecked_Conversion (System.Address, Tag_Ptr);
+
+   function To_Type_Specific_Data_Ptr is
+     new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
+
+   -------------------------------
+   -- Inline_Always Subprograms --
+   -------------------------------
+
+   --  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.
+
+   -------------------
+   -- 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
+      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 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;
+
+   -----------------
+   -- Is_Abstract --
+   -----------------
+
+   function Is_Abstract (T : Tag) return Boolean 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);
+      return TSD.Is_Abstract;
+   end Is_Abstract;
+
+   -------------------
+   -- Is_Primary_DT --
+   -------------------
+
+   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 --
+   -------------------------
+
+   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;
+      begin
+         J := 1;
+         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
+         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.HT_Link.all;
+      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
+         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.HT_Link.all := Next;
+      end Set_HT_Link;
+
+   end HTable_Subprograms;
+
+   ------------------
+   -- Base_Address --
+   ------------------
+
+   function Base_Address (This : System.Address) return System.Address is
+   begin
+      return This - Offset_To_Top (This);
+   end Base_Address;
+
+   ---------------
+   -- Check_TSD --
+   ---------------
+
+   procedure Check_TSD (TSD : Type_Specific_Data_Ptr) is
+      T : Tag;
+
+      E_Tag_Len : constant Integer := Length (TSD.External_Tag);
+      E_Tag     : String (1 .. E_Tag_Len);
+      for E_Tag'Address use TSD.External_Tag.all'Address;
+      pragma Import (Ada, E_Tag);
+
+      Dup_Ext_Tag : constant String := "duplicated external tag """;
+
+   begin
+      --  Verify that the external tag of this TSD is not registered in the
+      --  runtime hash table.
+
+      T := External_Tag_HTable.Get (To_Address (TSD.External_Tag));
+
+      if T /= null then
+
+         --  Avoid concatenation, as it is not allowed in no run time mode
+
+         declare
+            Msg : String (1 .. Dup_Ext_Tag'Length + E_Tag_Len + 1);
+         begin
+            Msg (1 .. Dup_Ext_Tag'Length) := Dup_Ext_Tag;
+            Msg (Dup_Ext_Tag'Length + 1 .. Dup_Ext_Tag'Length + E_Tag_Len) :=
+              E_Tag;
+            Msg (Msg'Last) := '"';
+            raise Program_Error with Msg;
+         end;
+      end if;
+   end Check_TSD;
+
+   --------------------
+   -- Descendant_Tag --
+   --------------------
+
+   function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
+      Int_Tag : constant Tag := Internal_Tag (External);
+   begin
+      if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
+         raise Tag_Error;
+      else
+         return Int_Tag;
+      end if;
+   end Descendant_Tag;
+
+   --------------
+   -- Displace --
+   --------------
+
+   function Displace (This : System.Address; T : Tag) return System.Address is
+      Iface_Table : Interface_Data_Ptr;
+      Obj_Base    : System.Address;
+      Obj_DT      : Dispatch_Table_Ptr;
+      Obj_DT_Tag  : Tag;
+
+   begin
+      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
+            if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then
+
+               --  Case of Static value of Offset_To_Top
+
+               if Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top then
+                  Obj_Base := Obj_Base +
+                    Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value;
+
+               --  Otherwise call the function generated by the expander to
+               --  provide the value.
+
+               else
+                  Obj_Base := Obj_Base +
+                    Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func.all
+                      (Obj_Base);
+               end if;
+
+               return Obj_Base;
+            end if;
+         end loop;
+      end if;
+
+      --  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_Tag, T) then
+         return Obj_Base;
+      end if;
+
+      --  If the object does not implement the interface we must raise CE
+
+      raise Constraint_Error with "invalid interface conversion";
+   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 --
+   -------------------
+
+   function IW_Membership
+     (Descendant_TSD : Type_Specific_Data_Ptr;
+      T              : Tag) return Boolean
+   is
+      Iface_Table : Interface_Data_Ptr;
+
+   begin
+      Iface_Table := Descendant_TSD.Interfaces_Table;
+
+      if Iface_Table /= null then
+         for Id in 1 .. Iface_Table.Nb_Ifaces loop
+            if Iface_Table.Ifaces_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 .. Descendant_TSD.Idepth loop
+         if Descendant_TSD.Tags_Table (Id) = T then
+            return True;
+         end if;
+      end loop;
+
+      return False;
+   end IW_Membership;
+
+   -------------------
+   -- 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
+      Obj_Base : System.Address;
+      Obj_DT   : Dispatch_Table_Ptr;
+      Obj_TSD  : Type_Specific_Data_Ptr;
+
+   begin
+      Obj_Base := Base_Address (This);
+      Obj_DT   := DT (To_Tag_Ptr (Obj_Base).all);
+      Obj_TSD  := To_Type_Specific_Data_Ptr (Obj_DT.TSD);
+
+      return IW_Membership (Obj_TSD, T);
+   end IW_Membership;
+
+   -------------------
+   -- Expanded_Name --
+   -------------------
+
+   function Expanded_Name (T : Tag) return String is
+      Result  : Cstring_Ptr;
+      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);
+      Result  := TSD.Expanded_Name;
+      return Result (1 .. Length (Result));
+   end Expanded_Name;
+
+   ------------------
+   -- External_Tag --
+   ------------------
+
+   function External_Tag (T : Tag) return String is
+      Result  : Cstring_Ptr;
+      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);
+      Result  := TSD.External_Tag;
+      return Result (1 .. Length (Result));
+   end External_Tag;
+
+   ---------------------
+   -- Get_Entry_Index --
+   ---------------------
+
+   function Get_Entry_Index (T : Tag; Position : Positive) return Positive is
+   begin
+      return SSD (T).SSD_Table (Position).Index;
+   end Get_Entry_Index;
+
+   ----------------------
+   -- Get_Prim_Op_Kind --
+   ----------------------
+
+   function Get_Prim_Op_Kind
+     (T        : Tag;
+      Position : Positive) return Prim_Op_Kind
+   is
+   begin
+      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
+      if Is_Primary_DT (T) then
+         return Position;
+      else
+         return OSD (T).OSD_Table (Position);
+      end if;
+   end Get_Offset_Index;
+
+   ---------------------
+   -- Get_Tagged_Kind --
+   ---------------------
+
+   function Get_Tagged_Kind (T : Tag) return Tagged_Kind is
+   begin
+      return DT (T).Tag_Kind;
+   end Get_Tagged_Kind;
+
+   -----------------------------
+   -- Interface_Ancestor_Tags --
+   -----------------------------
+
+   function Interface_Ancestor_Tags (T : Tag) return Tag_Array 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);
+      Iface_Table : constant Interface_Data_Ptr := TSD.Interfaces_Table;
+
+   begin
+      if Iface_Table = null then
+         declare
+            Table : Tag_Array (1 .. 0);
+         begin
+            return Table;
+         end;
+
+      else
+         declare
+            Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces);
+         begin
+            for J in 1 .. Iface_Table.Nb_Ifaces loop
+               Table (J) := Iface_Table.Ifaces_Table (J).Iface_Tag;
+            end loop;
+
+            return Table;
+         end;
+      end if;
+   end Interface_Ancestor_Tags;
+
+   ------------------
+   -- 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
+      pragma Unsuppress (All_Checks);
+      --  To make T'Class'Input robust in the case of bad data
+
+      Res : Tag := null;
+
+   begin
+      --  Raise Tag_Error for empty strings and very long strings. This makes
+      --  T'Class'Input robust in the case of bad data, for example
+      --
+      --    String (123456789..1234)
+      --
+      --  The limit of 10,000 characters is arbitrary, but is unlikely to be
+      --  exceeded by legitimate external tag names.
+
+      if External'Length not in 1 .. 10_000 then
+         raise Tag_Error;
+      end if;
+
+      --  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
+
+               --  Protect the run-time against wrong internal tags. We
+               --  cannot use exception handlers here because it would
+               --  disable the use of this run-time compiling with
+               --  restriction No_Exception_Handler.
+
+               declare
+                  C         : Character;
+                  Wrong_Tag : Boolean := False;
+
+               begin
+                  if External (Addr_First) /= '1'
+                    or else External (Addr_First + 1) /= '6'
+                    or else External (Addr_First + 2) /= '#'
+                  then
+                     Wrong_Tag := True;
+
+                  else
+                     for J in Addr_First + 3 .. Addr_Last - 1 loop
+                        C := External (J);
+
+                        if not (C in '0' .. '9')
+                          and then not (C in 'A' .. 'F')
+                          and then not (C in 'a' .. 'f')
+                        then
+                           Wrong_Tag := True;
+                           exit;
+                        end if;
+                     end loop;
+                  end if;
+
+                  --  Convert the numeric value into a tag
+
+                  if not Wrong_Tag then
+                     Addr := Integer_Address'Value
+                               (External (Addr_First .. Addr_Last));
+
+                     --  Internal tags never have value 0
+
+                     if Addr /= 0 then
+                        return To_Tag (Addr);
+                     end if;
+                  end if;
+               end;
+            end if;
+         end;
+
+      --  Handle library-level tagged types
+
+      else
+         --  Make NUL-terminated copy of external tag string
+
+         declare
+            Ext_Copy : aliased String (External'First .. External'Last + 1);
+            pragma Assert (Ext_Copy'Length > 1); -- See Length check at top
+         begin
+            Ext_Copy (External'Range) := External;
+            Ext_Copy (Ext_Copy'Last)  := ASCII.NUL;
+            Res := External_Tag_HTable.Get (Ext_Copy'Address);
+         end;
+      end if;
+
+      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
+      if Descendant = Ancestor then
+         return True;
+
+      else
+         declare
+            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
+              D_TSD.Access_Level = A_TSD.Access_Level
+                and then (CW_Membership (Descendant, Ancestor)
+                           or else IW_Membership (D_TSD, Ancestor));
+         end;
+      end if;
+   end Is_Descendant_At_Same_Level;
+
+   ------------
+   -- Length --
+   ------------
+
+   --  Note: This unit is used in the Ravenscar runtime library, so it cannot
+   --  depend on System.CTRL. Furthermore, this happens on CPUs where the GCC
+   --  intrinsic strlen may not be available, so we need to recode our own Ada
+   --  version here.
+
+   function Length (Str : Cstring_Ptr) return Natural is
+      Len : Integer;
+
+   begin
+      Len := 1;
+      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 SSE.Storage_Offset
+   is
+      Tag_Size : constant SSE.Storage_Count :=
+        SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
+
+      type Storage_Offset_Ptr is access SSE.Storage_Offset;
+      function To_Storage_Offset_Ptr is
+        new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
+
+      Curr_DT : Dispatch_Table_Ptr;
+
+   begin
+      Curr_DT := DT (To_Tag_Ptr (This).all);
+
+      --  See the documentation of Dispatch_Table_Wrapper.Offset_To_Top
+
+      if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then
+
+         --  The parent record type has variable-size components, so the
+         --  instance-specific offset is stored in the tagged record, right
+         --  after the reference to Curr_DT (which is a secondary dispatch
+         --  table).
+
+         return To_Storage_Offset_Ptr (This + Tag_Size).all;
+
+      else
+         --  The offset is compile-time known, so it is simply stored in the
+         --  Offset_To_Top field.
+
+         return Curr_DT.Offset_To_Top;
+      end if;
+   end Offset_To_Top;
+
+   ------------------------
+   -- Needs_Finalization --
+   ------------------------
+
+   function Needs_Finalization (T : Tag) return Boolean 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.Needs_Finalization;
+   end Needs_Finalization;
+
+   -----------------
+   -- Parent_Size --
+   -----------------
+
+   function Parent_Size
+     (Obj : System.Address;
+      T   : Tag) return SSE.Storage_Count
+   is
+      Parent_Slot : constant Positive := 1;
+      --  The tag of the parent is always in the first slot of the table of
+      --  ancestor tags.
+
+      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_TSD_Ptr : constant Addr_Ptr :=
+        To_Addr_Ptr (To_Address (Parent_Tag) - DT_Typeinfo_Ptr_Size);
+      Parent_TSD     : constant Type_Specific_Data_Ptr :=
+        To_Type_Specific_Data_Ptr (Parent_TSD_Ptr.all);
+
+   begin
+      --  Here we compute the size of the _parent field of the object
+
+      return SSE.Storage_Count (Parent_TSD.Size_Func.all (Obj));
+   end Parent_Size;
+
+   ----------------
+   -- Parent_Tag --
+   ----------------
+
+   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.Idepth = 0 then
+         return No_Tag;
+      else
+         return TSD.Tags_Table (1);
+      end if;
+   end Parent_Tag;
+
+   -------------------------------
+   -- Register_Interface_Offset --
+   -------------------------------
+
+   procedure Register_Interface_Offset
+     (Prim_T       : Tag;
+      Interface_T  : Tag;
+      Is_Static    : Boolean;
+      Offset_Value : SSE.Storage_Offset;
+      Offset_Func  : Offset_To_Top_Function_Ptr)
+   is
+      Prim_DT     : constant Dispatch_Table_Ptr := DT (Prim_T);
+      Iface_Table : constant Interface_Data_Ptr :=
+                      To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
+
+   begin
+      --  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
+               if Is_Static or else Offset_Value = 0 then
+                  Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := True;
+                  Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value  :=
+                    Offset_Value;
+               else
+                  Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False;
+                  Iface_Table.Ifaces_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 Register_Interface_Offset;
+
+   ------------------
+   -- Register_Tag --
+   ------------------
+
+   procedure Register_Tag (T : Tag) is
+   begin
+      External_Tag_HTable.Set (T);
+   end Register_Tag;
+
+   -------------------
+   -- Secondary_Tag --
+   -------------------
+
+   function Secondary_Tag (T, Iface : Tag) return Tag is
+      Iface_Table : Interface_Data_Ptr;
+      Obj_DT      : Dispatch_Table_Ptr;
+
+   begin
+      if not Is_Primary_DT (T) then
+         raise Program_Error;
+      end if;
+
+      Obj_DT      := DT (T);
+      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
+            if Iface_Table.Ifaces_Table (Id).Iface_Tag = Iface then
+               return Iface_Table.Ifaces_Table (Id).Secondary_DT;
+            end if;
+         end loop;
+      end if;
+
+      --  If the object does not implement the interface we must raise CE
+
+      raise Constraint_Error with "invalid interface conversion";
+   end Secondary_Tag;
+
+   ---------------------
+   -- Set_Entry_Index --
+   ---------------------
+
+   procedure Set_Entry_Index
+     (T        : Tag;
+      Position : Positive;
+      Value    : Positive)
+   is
+   begin
+      SSD (T).SSD_Table (Position).Index := Value;
+   end Set_Entry_Index;
+
+   -----------------------
+   -- Set_Offset_To_Top --
+   -----------------------
+
+   procedure Set_Dynamic_Offset_To_Top
+     (This         : System.Address;
+      Prim_T       : Tag;
+      Interface_T  : Tag;
+      Offset_Value : SSE.Storage_Offset;
+      Offset_Func  : Offset_To_Top_Function_Ptr)
+   is
+      Sec_Base : System.Address;
+      Sec_DT   : Dispatch_Table_Ptr;
+
+   begin
+      --  Save the offset to top field in the secondary dispatch table
+
+      if Offset_Value /= 0 then
+         Sec_Base := This + Offset_Value;
+         Sec_DT := DT (To_Tag_Ptr (Sec_Base).all);
+         Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last;
+      end if;
+
+      Register_Interface_Offset
+        (Prim_T, Interface_T, False, Offset_Value, Offset_Func);
+   end Set_Dynamic_Offset_To_Top;
+
+   ----------------------
+   -- Set_Prim_Op_Kind --
+   ----------------------
+
+   procedure Set_Prim_Op_Kind
+     (T        : Tag;
+      Position : Positive;
+      Value    : Prim_Op_Kind)
+   is
+   begin
+      SSD (T).SSD_Table (Position).Kind := Value;
+   end Set_Prim_Op_Kind;
+
+   --------------------
+   -- Unregister_Tag --
+   --------------------
+
+   procedure Unregister_Tag (T : Tag) is
+   begin
+      External_Tag_HTable.Remove (Get_External_Tag (T));
+   end Unregister_Tag;
+
+   ------------------------
+   -- 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
+      S : constant String := Expanded_Name (T);
+      W : Wide_String (1 .. S'Length);
+      L : Natural;
+   begin
+      String_To_Wide_String
+        (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
+      return W (1 .. L);
+   end Wide_Expanded_Name;
+
+   -----------------------------
+   -- Wide_Wide_Expanded_Name --
+   -----------------------------
+
+   function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is
+      S : constant String := Expanded_Name (T);
+      W : Wide_Wide_String (1 .. S'Length);
+      L : Natural;
+   begin
+      String_To_Wide_Wide_String
+        (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
+      return W (1 .. L);
+   end Wide_Wide_Expanded_Name;
+
+end Ada.Tags;