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