gcc/ada/a-tags.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                             A D A . T A G S                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2016, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Ada.Exceptions;
  33 with Ada.Unchecked_Conversion;
  34
  35 with System.HTable;
  36 with System.Storage_Elements; use System.Storage_Elements;
  37 with System.WCh_Con;          use System.WCh_Con;
  38 with System.WCh_StW;          use System.WCh_StW;
  39
  40 pragma Elaborate (System.HTable);
  41 --  Elaborate needed instead of Elaborate_All to avoid elaboration cycles
  42 --  when polling is turned on. This is safe because HTable doesn't do anything
  43 --  at elaboration time; it just contains a generic package we want to
  44 --  instantiate.
  45
  46 package body Ada.Tags is
  47
  48    -----------------------
  49    -- Local Subprograms --
  50    -----------------------
  51
  52    function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
  53    --  Given the tag of an object and the tag associated to a type, return
  54    --  true if Obj is in Typ'Class.
  55
  56    function Get_External_Tag (T : Tag) return System.Address;
  57    --  Returns address of a null terminated string containing the external name
  58
  59    function Is_Primary_DT (T : Tag) return Boolean;
  60    --  Given a tag returns True if it has the signature of a primary dispatch
  61    --  table.  This is Inline_Always since it is called from other Inline_
  62    --  Always subprograms where we want no out of line code to be generated.
  63
  64    function IW_Membership
  65      (Descendant_TSD : Type_Specific_Data_Ptr;
  66       T              : Tag) return Boolean;
  67    --  Subsidiary function of IW_Membership and CW_Membership which factorizes
  68    --  the functionality needed to check if a given descendant implements an
  69    --  interface tag T.
  70
  71    function Length (Str : Cstring_Ptr) return Natural;
  72    --  Length of string represented by the given pointer (treating the string
  73    --  as a C-style string, which is Nul terminated). See comment in body
  74    --  explaining why we cannot use the normal strlen built-in.
  75
  76    function OSD (T : Tag) return Object_Specific_Data_Ptr;
  77    --  Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table,
  78    --  retrieve the address of the record containing the Object Specific
  79    --  Data table.
  80
  81    function SSD (T : Tag) return Select_Specific_Data_Ptr;
  82    --  Ada 2005 (AI-251): Given a pointer T to a dispatch Table, retrieves the
  83    --  address of the record containing the Select Specific Data in T's TSD.
  84
  85    pragma Inline_Always (CW_Membership);
  86    pragma Inline_Always (Get_External_Tag);
  87    pragma Inline_Always (Is_Primary_DT);
  88    pragma Inline_Always (OSD);
  89    pragma Inline_Always (SSD);
  90
  91    --  Unchecked conversions
  92
  93    function To_Address is
  94      new Unchecked_Conversion (Cstring_Ptr, System.Address);
  95
  96    function To_Cstring_Ptr is
  97      new Unchecked_Conversion (System.Address, Cstring_Ptr);
  98
  99    --  Disable warnings on possible aliasing problem
 100
 101    function To_Tag is
 102      new Unchecked_Conversion (Integer_Address, Tag);
 103
 104    function To_Addr_Ptr is
 105       new Ada.Unchecked_Conversion (System.Address, Addr_Ptr);
 106
 107    function To_Address is
 108      new Ada.Unchecked_Conversion (Tag, System.Address);
 109
 110    function To_Dispatch_Table_Ptr is
 111       new Ada.Unchecked_Conversion (Tag, Dispatch_Table_Ptr);
 112
 113    function To_Dispatch_Table_Ptr is
 114       new Ada.Unchecked_Conversion (System.Address, Dispatch_Table_Ptr);
 115
 116    function To_Object_Specific_Data_Ptr is
 117      new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr);
 118
 119    function To_Tag_Ptr is
 120      new Ada.Unchecked_Conversion (System.Address, Tag_Ptr);
 121
 122    function To_Type_Specific_Data_Ptr is
 123      new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
 124
 125    -------------------------------
 126    -- Inline_Always Subprograms --
 127    -------------------------------
 128
 129    --  Inline_always subprograms must be placed before their first call to
 130    --  avoid defeating the frontend inlining mechanism and thus ensure the
 131    --  generation of their correct debug info.
 132
 133    -------------------
 134    -- CW_Membership --
 135    -------------------
 136
 137    --  Canonical implementation of Classwide Membership corresponding to:
 138
 139    --     Obj in Typ'Class
 140
 141    --  Each dispatch table contains a reference to a table of ancestors (stored
 142    --  in the first part of the Tags_Table) and a count of the level of
 143    --  inheritance "Idepth".
 144
 145    --  Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
 146    --  contained in the dispatch table referenced by Obj'Tag . Knowing the
 147    --  level of inheritance of both types, this can be computed in constant
 148    --  time by the formula:
 149
 150    --   TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
 151    --     = Typ'tag
 152
 153    function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
 154       Obj_TSD_Ptr : constant Addr_Ptr :=
 155         To_Addr_Ptr (To_Address (Obj_Tag) - DT_Typeinfo_Ptr_Size);
 156       Typ_TSD_Ptr : constant Addr_Ptr :=
 157         To_Addr_Ptr (To_Address (Typ_Tag) - DT_Typeinfo_Ptr_Size);
 158       Obj_TSD     : constant Type_Specific_Data_Ptr :=
 159         To_Type_Specific_Data_Ptr (Obj_TSD_Ptr.all);
 160       Typ_TSD     : constant Type_Specific_Data_Ptr :=
 161         To_Type_Specific_Data_Ptr (Typ_TSD_Ptr.all);
 162       Pos         : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth;
 163    begin
 164       return Pos >= 0 and then Obj_TSD.Tags_Table (Pos) = Typ_Tag;
 165    end CW_Membership;
 166
 167    ----------------------
 168    -- Get_External_Tag --
 169    ----------------------
 170
 171    function Get_External_Tag (T : Tag) return System.Address is
 172       TSD_Ptr : constant Addr_Ptr :=
 173         To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 174       TSD     : constant Type_Specific_Data_Ptr :=
 175         To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 176    begin
 177       return To_Address (TSD.External_Tag);
 178    end Get_External_Tag;
 179
 180    -------------------
 181    -- Is_Primary_DT --
 182    -------------------
 183
 184    function Is_Primary_DT (T : Tag) return Boolean is
 185    begin
 186       return DT (T).Signature = Primary_DT;
 187    end Is_Primary_DT;
 188
 189    ---------
 190    -- OSD --
 191    ---------
 192
 193    function OSD (T : Tag) return Object_Specific_Data_Ptr is
 194       OSD_Ptr : constant Addr_Ptr :=
 195                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 196    begin
 197       return To_Object_Specific_Data_Ptr (OSD_Ptr.all);
 198    end OSD;
 199
 200    ---------
 201    -- SSD --
 202    ---------
 203
 204    function SSD (T : Tag) return Select_Specific_Data_Ptr is
 205       TSD_Ptr : constant Addr_Ptr :=
 206                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 207       TSD     : constant Type_Specific_Data_Ptr :=
 208                   To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 209    begin
 210       return TSD.SSD;
 211    end SSD;
 212
 213    -------------------------
 214    -- External_Tag_HTable --
 215    -------------------------
 216
 217    type HTable_Headers is range 1 .. 64;
 218
 219    --  The following internal package defines the routines used for the
 220    --  instantiation of a new System.HTable.Static_HTable (see below). See
 221    --  spec in g-htable.ads for details of usage.
 222
 223    package HTable_Subprograms is
 224       procedure Set_HT_Link (T : Tag; Next : Tag);
 225       function  Get_HT_Link (T : Tag) return Tag;
 226       function Hash (F : System.Address) return HTable_Headers;
 227       function Equal (A, B : System.Address) return Boolean;
 228    end HTable_Subprograms;
 229
 230    package External_Tag_HTable is new System.HTable.Static_HTable (
 231      Header_Num => HTable_Headers,
 232      Element    => Dispatch_Table,
 233      Elmt_Ptr   => Tag,
 234      Null_Ptr   => null,
 235      Set_Next   => HTable_Subprograms.Set_HT_Link,
 236      Next       => HTable_Subprograms.Get_HT_Link,
 237      Key        => System.Address,
 238      Get_Key    => Get_External_Tag,
 239      Hash       => HTable_Subprograms.Hash,
 240      Equal      => HTable_Subprograms.Equal);
 241
 242    ------------------------
 243    -- HTable_Subprograms --
 244    ------------------------
 245
 246    --  Bodies of routines for hash table instantiation
 247
 248    package body HTable_Subprograms is
 249
 250       -----------
 251       -- Equal --
 252       -----------
 253
 254       function Equal (A, B : System.Address) return Boolean is
 255          Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
 256          Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
 257          J    : Integer;
 258       begin
 259          J := 1;
 260          loop
 261             if Str1 (J) /= Str2 (J) then
 262                return False;
 263             elsif Str1 (J) = ASCII.NUL then
 264                return True;
 265             else
 266                J := J + 1;
 267             end if;
 268          end loop;
 269       end Equal;
 270
 271       -----------------
 272       -- Get_HT_Link --
 273       -----------------
 274
 275       function Get_HT_Link (T : Tag) return Tag is
 276          TSD_Ptr : constant Addr_Ptr :=
 277                      To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 278          TSD     : constant Type_Specific_Data_Ptr :=
 279                      To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 280       begin
 281          return TSD.HT_Link.all;
 282       end Get_HT_Link;
 283
 284       ----------
 285       -- Hash --
 286       ----------
 287
 288       function Hash (F : System.Address) return HTable_Headers is
 289          function H is new System.HTable.Hash (HTable_Headers);
 290          Str : constant Cstring_Ptr    := To_Cstring_Ptr (F);
 291          Res : constant HTable_Headers := H (Str (1 .. Length (Str)));
 292       begin
 293          return Res;
 294       end Hash;
 295
 296       -----------------
 297       -- Set_HT_Link --
 298       -----------------
 299
 300       procedure Set_HT_Link (T : Tag; Next : Tag) is
 301          TSD_Ptr : constant Addr_Ptr :=
 302                      To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 303          TSD     : constant Type_Specific_Data_Ptr :=
 304                      To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 305       begin
 306          TSD.HT_Link.all := Next;
 307       end Set_HT_Link;
 308
 309    end HTable_Subprograms;
 310
 311    ------------------
 312    -- Base_Address --
 313    ------------------
 314
 315    function Base_Address (This : System.Address) return System.Address is
 316    begin
 317       return This - Offset_To_Top (This);
 318    end Base_Address;
 319
 320    ---------------
 321    -- Check_TSD --
 322    ---------------
 323
 324    procedure Check_TSD (TSD : Type_Specific_Data_Ptr) is
 325       T : Tag;
 326
 327       E_Tag_Len : constant Integer := Length (TSD.External_Tag);
 328       E_Tag     : String (1 .. E_Tag_Len);
 329       for E_Tag'Address use TSD.External_Tag.all'Address;
 330       pragma Import (Ada, E_Tag);
 331
 332       Dup_Ext_Tag : constant String := "duplicated external tag """;
 333
 334    begin
 335       --  Verify that the external tag of this TSD is not registered in the
 336       --  runtime hash table.
 337
 338       T := External_Tag_HTable.Get (To_Address (TSD.External_Tag));
 339
 340       if T /= null then
 341
 342          --  Avoid concatenation, as it is not allowed in no run time mode
 343
 344          declare
 345             Msg : String (1 .. Dup_Ext_Tag'Length + E_Tag_Len + 1);
 346          begin
 347             Msg (1 .. Dup_Ext_Tag'Length) := Dup_Ext_Tag;
 348             Msg (Dup_Ext_Tag'Length + 1 .. Dup_Ext_Tag'Length + E_Tag_Len) :=
 349               E_Tag;
 350             Msg (Msg'Last) := '"';
 351             raise Program_Error with Msg;
 352          end;
 353       end if;
 354    end Check_TSD;
 355
 356    --------------------
 357    -- Descendant_Tag --
 358    --------------------
 359
 360    function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
 361       Int_Tag : constant Tag := Internal_Tag (External);
 362    begin
 363       if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
 364          raise Tag_Error;
 365       else
 366          return Int_Tag;
 367       end if;
 368    end Descendant_Tag;
 369
 370    --------------
 371    -- Displace --
 372    --------------
 373
 374    function Displace (This : System.Address; T : Tag) return System.Address is
 375       Iface_Table : Interface_Data_Ptr;
 376       Obj_Base    : System.Address;
 377       Obj_DT      : Dispatch_Table_Ptr;
 378       Obj_DT_Tag  : Tag;
 379
 380    begin
 381       if System."=" (This, System.Null_Address) then
 382          return System.Null_Address;
 383       end if;
 384
 385       Obj_Base    := Base_Address (This);
 386       Obj_DT_Tag  := To_Tag_Ptr (Obj_Base).all;
 387       Obj_DT      := DT (To_Tag_Ptr (Obj_Base).all);
 388       Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table;
 389
 390       if Iface_Table /= null then
 391          for Id in 1 .. Iface_Table.Nb_Ifaces loop
 392             if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then
 393
 394                --  Case of Static value of Offset_To_Top
 395
 396                if Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top then
 397                   Obj_Base := Obj_Base +
 398                     Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value;
 399
 400                --  Otherwise call the function generated by the expander to
 401                --  provide the value.
 402
 403                else
 404                   Obj_Base := Obj_Base +
 405                     Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func.all
 406                       (Obj_Base);
 407                end if;
 408
 409                return Obj_Base;
 410             end if;
 411          end loop;
 412       end if;
 413
 414       --  Check if T is an immediate ancestor. This is required to handle
 415       --  conversion of class-wide interfaces to tagged types.
 416
 417       if CW_Membership (Obj_DT_Tag, T) then
 418          return Obj_Base;
 419       end if;
 420
 421       --  If the object does not implement the interface we must raise CE
 422
 423       raise Constraint_Error with "invalid interface conversion";
 424    end Displace;
 425
 426    --------
 427    -- DT --
 428    --------
 429
 430    function DT (T : Tag) return Dispatch_Table_Ptr is
 431       Offset : constant SSE.Storage_Offset :=
 432                  To_Dispatch_Table_Ptr (T).Prims_Ptr'Position;
 433    begin
 434       return To_Dispatch_Table_Ptr (To_Address (T) - Offset);
 435    end DT;
 436
 437    -------------------
 438    -- IW_Membership --
 439    -------------------
 440
 441    function IW_Membership
 442      (Descendant_TSD : Type_Specific_Data_Ptr;
 443       T              : Tag) return Boolean
 444    is
 445       Iface_Table : Interface_Data_Ptr;
 446
 447    begin
 448       Iface_Table := Descendant_TSD.Interfaces_Table;
 449
 450       if Iface_Table /= null then
 451          for Id in 1 .. Iface_Table.Nb_Ifaces loop
 452             if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then
 453                return True;
 454             end if;
 455          end loop;
 456       end if;
 457
 458       --  Look for the tag in the ancestor tags table. This is required for:
 459       --     Iface_CW in Typ'Class
 460
 461       for Id in 0 .. Descendant_TSD.Idepth loop
 462          if Descendant_TSD.Tags_Table (Id) = T then
 463             return True;
 464          end if;
 465       end loop;
 466
 467       return False;
 468    end IW_Membership;
 469
 470    -------------------
 471    -- IW_Membership --
 472    -------------------
 473
 474    --  Canonical implementation of Classwide Membership corresponding to:
 475
 476    --     Obj in Iface'Class
 477
 478    --  Each dispatch table contains a table with the tags of all the
 479    --  implemented interfaces.
 480
 481    --  Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
 482    --  that are contained in the dispatch table referenced by Obj'Tag.
 483
 484    function IW_Membership (This : System.Address; T : Tag) return Boolean is
 485       Obj_Base : System.Address;
 486       Obj_DT   : Dispatch_Table_Ptr;
 487       Obj_TSD  : Type_Specific_Data_Ptr;
 488
 489    begin
 490       Obj_Base := Base_Address (This);
 491       Obj_DT   := DT (To_Tag_Ptr (Obj_Base).all);
 492       Obj_TSD  := To_Type_Specific_Data_Ptr (Obj_DT.TSD);
 493
 494       return IW_Membership (Obj_TSD, T);
 495    end IW_Membership;
 496
 497    -------------------
 498    -- Expanded_Name --
 499    -------------------
 500
 501    function Expanded_Name (T : Tag) return String is
 502       Result  : Cstring_Ptr;
 503       TSD_Ptr : Addr_Ptr;
 504       TSD     : Type_Specific_Data_Ptr;
 505
 506    begin
 507       if T = No_Tag then
 508          raise Tag_Error;
 509       end if;
 510
 511       TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 512       TSD     := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 513       Result  := TSD.Expanded_Name;
 514       return Result (1 .. Length (Result));
 515    end Expanded_Name;
 516
 517    ------------------
 518    -- External_Tag --
 519    ------------------
 520
 521    function External_Tag (T : Tag) return String is
 522       Result  : Cstring_Ptr;
 523       TSD_Ptr : Addr_Ptr;
 524       TSD     : Type_Specific_Data_Ptr;
 525
 526    begin
 527       if T = No_Tag then
 528          raise Tag_Error;
 529       end if;
 530
 531       TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 532       TSD     := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 533       Result  := TSD.External_Tag;
 534       return Result (1 .. Length (Result));
 535    end External_Tag;
 536
 537    ---------------------
 538    -- Get_Entry_Index --
 539    ---------------------
 540
 541    function Get_Entry_Index (T : Tag; Position : Positive) return Positive is
 542    begin
 543       return SSD (T).SSD_Table (Position).Index;
 544    end Get_Entry_Index;
 545
 546    ----------------------
 547    -- Get_Prim_Op_Kind --
 548    ----------------------
 549
 550    function Get_Prim_Op_Kind
 551      (T        : Tag;
 552       Position : Positive) return Prim_Op_Kind
 553    is
 554    begin
 555       return SSD (T).SSD_Table (Position).Kind;
 556    end Get_Prim_Op_Kind;
 557
 558    ----------------------
 559    -- Get_Offset_Index --
 560    ----------------------
 561
 562    function Get_Offset_Index
 563      (T        : Tag;
 564       Position : Positive) return Positive
 565    is
 566    begin
 567       if Is_Primary_DT (T) then
 568          return Position;
 569       else
 570          return OSD (T).OSD_Table (Position);
 571       end if;
 572    end Get_Offset_Index;
 573
 574    ---------------------
 575    -- Get_Tagged_Kind --
 576    ---------------------
 577
 578    function Get_Tagged_Kind (T : Tag) return Tagged_Kind is
 579    begin
 580       return DT (T).Tag_Kind;
 581    end Get_Tagged_Kind;
 582
 583    -----------------------------
 584    -- Interface_Ancestor_Tags --
 585    -----------------------------
 586
 587    function Interface_Ancestor_Tags (T : Tag) return Tag_Array is
 588       TSD_Ptr     : constant Addr_Ptr :=
 589                       To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 590       TSD         : constant Type_Specific_Data_Ptr :=
 591                       To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 592       Iface_Table : constant Interface_Data_Ptr := TSD.Interfaces_Table;
 593
 594    begin
 595       if Iface_Table = null then
 596          declare
 597             Table : Tag_Array (1 .. 0);
 598          begin
 599             return Table;
 600          end;
 601
 602       else
 603          declare
 604             Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces);
 605          begin
 606             for J in 1 .. Iface_Table.Nb_Ifaces loop
 607                Table (J) := Iface_Table.Ifaces_Table (J).Iface_Tag;
 608             end loop;
 609
 610             return Table;
 611          end;
 612       end if;
 613    end Interface_Ancestor_Tags;
 614
 615    ------------------
 616    -- Internal_Tag --
 617    ------------------
 618
 619    --  Internal tags have the following format:
 620    --    "Internal tag at 16#ADDRESS#: <full-name-of-tagged-type>"
 621
 622    Internal_Tag_Header : constant String    := "Internal tag at ";
 623    Header_Separator    : constant Character := '#';
 624
 625    function Internal_Tag (External : String) return Tag is
 626       Ext_Copy : aliased String (External'First .. External'Last + 1);
 627       Res      : Tag := null;
 628
 629    begin
 630       --  Handle locally defined tagged types
 631
 632       if External'Length > Internal_Tag_Header'Length
 633         and then
 634           External (External'First ..
 635                       External'First + Internal_Tag_Header'Length - 1) =
 636                                                         Internal_Tag_Header
 637       then
 638          declare
 639             Addr_First : constant Natural :=
 640                            External'First + Internal_Tag_Header'Length;
 641             Addr_Last  : Natural;
 642             Addr       : Integer_Address;
 643
 644          begin
 645             --  Search the second separator (#) to identify the address
 646
 647             Addr_Last := Addr_First;
 648
 649             for J in 1 .. 2 loop
 650                while Addr_Last <= External'Last
 651                  and then External (Addr_Last) /= Header_Separator
 652                loop
 653                   Addr_Last := Addr_Last + 1;
 654                end loop;
 655
 656                --  Skip the first separator
 657
 658                if J = 1 then
 659                   Addr_Last := Addr_Last + 1;
 660                end if;
 661             end loop;
 662
 663             if Addr_Last <= External'Last then
 664
 665                --  Protect the run-time against wrong internal tags. We
 666                --  cannot use exception handlers here because it would
 667                --  disable the use of this run-time compiling with
 668                --  restriction No_Exception_Handler.
 669
 670                declare
 671                   C         : Character;
 672                   Wrong_Tag : Boolean := False;
 673
 674                begin
 675                   if External (Addr_First) /= '1'
 676                     or else External (Addr_First + 1) /= '6'
 677                     or else External (Addr_First + 2) /= '#'
 678                   then
 679                      Wrong_Tag := True;
 680
 681                   else
 682                      for J in Addr_First + 3 .. Addr_Last - 1 loop
 683                         C := External (J);
 684
 685                         if not (C in '0' .. '9')
 686                           and then not (C in 'A' .. 'F')
 687                           and then not (C in 'a' .. 'f')
 688                         then
 689                            Wrong_Tag := True;
 690                            exit;
 691                         end if;
 692                      end loop;
 693                   end if;
 694
 695                   --  Convert the numeric value into a tag
 696
 697                   if not Wrong_Tag then
 698                      Addr := Integer_Address'Value
 699                                (External (Addr_First .. Addr_Last));
 700
 701                      --  Internal tags never have value 0
 702
 703                      if Addr /= 0 then
 704                         return To_Tag (Addr);
 705                      end if;
 706                   end if;
 707                end;
 708             end if;
 709          end;
 710
 711       --  Handle library-level tagged types
 712
 713       else
 714          --  Make NUL-terminated copy of external tag string
 715
 716          Ext_Copy (External'Range) := External;
 717          Ext_Copy (Ext_Copy'Last)  := ASCII.NUL;
 718          Res := External_Tag_HTable.Get (Ext_Copy'Address);
 719       end if;
 720
 721       if Res = null then
 722          declare
 723             Msg1 : constant String := "unknown tagged type: ";
 724             Msg2 : String (1 .. Msg1'Length + External'Length);
 725
 726          begin
 727             Msg2 (1 .. Msg1'Length) := Msg1;
 728             Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
 729               External;
 730             Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2);
 731          end;
 732       end if;
 733
 734       return Res;
 735    end Internal_Tag;
 736
 737    ---------------------------------
 738    -- Is_Descendant_At_Same_Level --
 739    ---------------------------------
 740
 741    function Is_Descendant_At_Same_Level
 742      (Descendant : Tag;
 743       Ancestor   : Tag) return Boolean
 744    is
 745    begin
 746       if Descendant = Ancestor then
 747          return True;
 748
 749       else
 750          declare
 751             D_TSD_Ptr : constant Addr_Ptr :=
 752               To_Addr_Ptr (To_Address (Descendant) - DT_Typeinfo_Ptr_Size);
 753             A_TSD_Ptr : constant Addr_Ptr :=
 754               To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size);
 755             D_TSD     : constant Type_Specific_Data_Ptr :=
 756               To_Type_Specific_Data_Ptr (D_TSD_Ptr.all);
 757             A_TSD     : constant Type_Specific_Data_Ptr :=
 758               To_Type_Specific_Data_Ptr (A_TSD_Ptr.all);
 759          begin
 760             return
 761               D_TSD.Access_Level = A_TSD.Access_Level
 762                 and then (CW_Membership (Descendant, Ancestor)
 763                            or else IW_Membership (D_TSD, Ancestor));
 764          end;
 765       end if;
 766    end Is_Descendant_At_Same_Level;
 767
 768    ------------
 769    -- Length --
 770    ------------
 771
 772    --  Note: This unit is used in the Ravenscar runtime library, so it cannot
 773    --  depend on System.CTRL. Furthermore, this happens on CPUs where the GCC
 774    --  intrinsic strlen may not be available, so we need to recode our own Ada
 775    --  version here.
 776
 777    function Length (Str : Cstring_Ptr) return Natural is
 778       Len : Integer;
 779
 780    begin
 781       Len := 1;
 782       while Str (Len) /= ASCII.NUL loop
 783          Len := Len + 1;
 784       end loop;
 785
 786       return Len - 1;
 787    end Length;
 788
 789    -------------------
 790    -- Offset_To_Top --
 791    -------------------
 792
 793    function Offset_To_Top
 794      (This : System.Address) return SSE.Storage_Offset
 795    is
 796       Tag_Size : constant SSE.Storage_Count :=
 797         SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
 798
 799       type Storage_Offset_Ptr is access SSE.Storage_Offset;
 800       function To_Storage_Offset_Ptr is
 801         new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
 802
 803       Curr_DT : Dispatch_Table_Ptr;
 804
 805    begin
 806       Curr_DT := DT (To_Tag_Ptr (This).all);
 807
 808       if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then
 809          return To_Storage_Offset_Ptr (This + Tag_Size).all;
 810       else
 811          return Curr_DT.Offset_To_Top;
 812       end if;
 813    end Offset_To_Top;
 814
 815    ------------------------
 816    -- Needs_Finalization --
 817    ------------------------
 818
 819    function Needs_Finalization (T : Tag) return Boolean is
 820       TSD_Ptr : constant Addr_Ptr :=
 821                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 822       TSD     : constant Type_Specific_Data_Ptr :=
 823                   To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 824    begin
 825       return TSD.Needs_Finalization;
 826    end Needs_Finalization;
 827
 828    -----------------
 829    -- Parent_Size --
 830    -----------------
 831
 832    function Parent_Size
 833      (Obj : System.Address;
 834       T   : Tag) return SSE.Storage_Count
 835    is
 836       Parent_Slot : constant Positive := 1;
 837       --  The tag of the parent is always in the first slot of the table of
 838       --  ancestor tags.
 839
 840       TSD_Ptr : constant Addr_Ptr :=
 841                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 842       TSD     : constant Type_Specific_Data_Ptr :=
 843                   To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 844       --  Pointer to the TSD
 845
 846       Parent_Tag     : constant Tag := TSD.Tags_Table (Parent_Slot);
 847       Parent_TSD_Ptr : constant Addr_Ptr :=
 848         To_Addr_Ptr (To_Address (Parent_Tag) - DT_Typeinfo_Ptr_Size);
 849       Parent_TSD     : constant Type_Specific_Data_Ptr :=
 850         To_Type_Specific_Data_Ptr (Parent_TSD_Ptr.all);
 851
 852    begin
 853       --  Here we compute the size of the _parent field of the object
 854
 855       return SSE.Storage_Count (Parent_TSD.Size_Func.all (Obj));
 856    end Parent_Size;
 857
 858    ----------------
 859    -- Parent_Tag --
 860    ----------------
 861
 862    function Parent_Tag (T : Tag) return Tag is
 863       TSD_Ptr : Addr_Ptr;
 864       TSD     : Type_Specific_Data_Ptr;
 865
 866    begin
 867       if T = No_Tag then
 868          raise Tag_Error;
 869       end if;
 870
 871       TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 872       TSD     := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 873
 874       --  The Parent_Tag of a root-level tagged type is defined to be No_Tag.
 875       --  The first entry in the Ancestors_Tags array will be null for such
 876       --  a type, but it's better to be explicit about returning No_Tag in
 877       --  this case.
 878
 879       if TSD.Idepth = 0 then
 880          return No_Tag;
 881       else
 882          return TSD.Tags_Table (1);
 883       end if;
 884    end Parent_Tag;
 885
 886    -------------------------------
 887    -- Register_Interface_Offset --
 888    -------------------------------
 889
 890    procedure Register_Interface_Offset
 891      (This         : System.Address;
 892       Interface_T  : Tag;
 893       Is_Static    : Boolean;
 894       Offset_Value : SSE.Storage_Offset;
 895       Offset_Func  : Offset_To_Top_Function_Ptr)
 896    is
 897       Prim_DT     : Dispatch_Table_Ptr;
 898       Iface_Table : Interface_Data_Ptr;
 899
 900    begin
 901       --  "This" points to the primary DT and we must save Offset_Value in
 902       --  the Offset_To_Top field of the corresponding dispatch table.
 903
 904       Prim_DT     := DT (To_Tag_Ptr (This).all);
 905       Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
 906
 907       --  Save Offset_Value in the table of interfaces of the primary DT.
 908       --  This data will be used by the subprogram "Displace" to give support
 909       --  to backward abstract interface type conversions.
 910
 911       --  Register the offset in the table of interfaces
 912
 913       if Iface_Table /= null then
 914          for Id in 1 .. Iface_Table.Nb_Ifaces loop
 915             if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then
 916                if Is_Static or else Offset_Value = 0 then
 917                   Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := True;
 918                   Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value :=
 919                     Offset_Value;
 920                else
 921                   Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False;
 922                   Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func :=
 923                     Offset_Func;
 924                end if;
 925
 926                return;
 927             end if;
 928          end loop;
 929       end if;
 930
 931       --  If we arrive here there is some error in the run-time data structure
 932
 933       raise Program_Error;
 934    end Register_Interface_Offset;
 935
 936    ------------------
 937    -- Register_Tag --
 938    ------------------
 939
 940    procedure Register_Tag (T : Tag) is
 941    begin
 942       External_Tag_HTable.Set (T);
 943    end Register_Tag;
 944
 945    -------------------
 946    -- Secondary_Tag --
 947    -------------------
 948
 949    function Secondary_Tag (T, Iface : Tag) return Tag is
 950       Iface_Table : Interface_Data_Ptr;
 951       Obj_DT      : Dispatch_Table_Ptr;
 952
 953    begin
 954       if not Is_Primary_DT (T) then
 955          raise Program_Error;
 956       end if;
 957
 958       Obj_DT      := DT (T);
 959       Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table;
 960
 961       if Iface_Table /= null then
 962          for Id in 1 .. Iface_Table.Nb_Ifaces loop
 963             if Iface_Table.Ifaces_Table (Id).Iface_Tag = Iface then
 964                return Iface_Table.Ifaces_Table (Id).Secondary_DT;
 965             end if;
 966          end loop;
 967       end if;
 968
 969       --  If the object does not implement the interface we must raise CE
 970
 971       raise Constraint_Error with "invalid interface conversion";
 972    end Secondary_Tag;
 973
 974    ---------------------
 975    -- Set_Entry_Index --
 976    ---------------------
 977
 978    procedure Set_Entry_Index
 979      (T        : Tag;
 980       Position : Positive;
 981       Value    : Positive)
 982    is
 983    begin
 984       SSD (T).SSD_Table (Position).Index := Value;
 985    end Set_Entry_Index;
 986
 987    -----------------------
 988    -- Set_Offset_To_Top --
 989    -----------------------
 990
 991    procedure Set_Dynamic_Offset_To_Top
 992      (This         : System.Address;
 993       Interface_T  : Tag;
 994       Offset_Value : SSE.Storage_Offset;
 995       Offset_Func  : Offset_To_Top_Function_Ptr)
 996    is
 997       Sec_Base : System.Address;
 998       Sec_DT   : Dispatch_Table_Ptr;
 999
1000    begin
1001       --  Save the offset to top field in the secondary dispatch table
1002
1003       if Offset_Value /= 0 then
1004          Sec_Base := This + Offset_Value;
1005          Sec_DT := DT (To_Tag_Ptr (Sec_Base).all);
1006          Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last;
1007       end if;
1008
1009       Register_Interface_Offset
1010         (This, Interface_T, False, Offset_Value, Offset_Func);
1011    end Set_Dynamic_Offset_To_Top;
1012
1013    ----------------------
1014    -- Set_Prim_Op_Kind --
1015    ----------------------
1016
1017    procedure Set_Prim_Op_Kind
1018      (T        : Tag;
1019       Position : Positive;
1020       Value    : Prim_Op_Kind)
1021    is
1022    begin
1023       SSD (T).SSD_Table (Position).Kind := Value;
1024    end Set_Prim_Op_Kind;
1025
1026    ----------------------
1027    -- Type_Is_Abstract --
1028    ----------------------
1029
1030    function Type_Is_Abstract (T : Tag) return Boolean is
1031       TSD_Ptr : Addr_Ptr;
1032       TSD     : Type_Specific_Data_Ptr;
1033
1034    begin
1035       if T = No_Tag then
1036          raise Tag_Error;
1037       end if;
1038
1039       TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
1040       TSD     := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
1041       return TSD.Type_Is_Abstract;
1042    end Type_Is_Abstract;
1043
1044    --------------------
1045    -- Unregister_Tag --
1046    --------------------
1047
1048    procedure Unregister_Tag (T : Tag) is
1049    begin
1050       External_Tag_HTable.Remove (Get_External_Tag (T));
1051    end Unregister_Tag;
1052
1053    ------------------------
1054    -- Wide_Expanded_Name --
1055    ------------------------
1056
1057    WC_Encoding : Character;
1058    pragma Import (C, WC_Encoding, "__gl_wc_encoding");
1059    --  Encoding method for source, as exported by binder
1060
1061    function Wide_Expanded_Name (T : Tag) return Wide_String is
1062       S : constant String := Expanded_Name (T);
1063       W : Wide_String (1 .. S'Length);
1064       L : Natural;
1065    begin
1066       String_To_Wide_String
1067         (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
1068       return W (1 .. L);
1069    end Wide_Expanded_Name;
1070
1071    -----------------------------
1072    -- Wide_Wide_Expanded_Name --
1073    -----------------------------
1074
1075    function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is
1076       S : constant String := Expanded_Name (T);
1077       W : Wide_Wide_String (1 .. S'Length);
1078       L : Natural;
1079    begin
1080       String_To_Wide_Wide_String
1081         (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
1082       return W (1 .. L);
1083    end Wide_Wide_Expanded_Name;
1084
1085 end Ada.Tags;