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