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-2011, 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)
 722                                    - DT_Typeinfo_Ptr_Size);
 723       A_TSD_Ptr : constant Addr_Ptr :=
 724                     To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size);
 725       D_TSD     : constant Type_Specific_Data_Ptr :=
 726                     To_Type_Specific_Data_Ptr (D_TSD_Ptr.all);
 727       A_TSD     : constant Type_Specific_Data_Ptr :=
 728                     To_Type_Specific_Data_Ptr (A_TSD_Ptr.all);
 729
 730    begin
 731       return CW_Membership (Descendant, Ancestor)
 732         and then D_TSD.Access_Level = A_TSD.Access_Level;
 733    end Is_Descendant_At_Same_Level;
 734
 735    ------------
 736    -- Length --
 737    ------------
 738
 739    --  Should this be reimplemented using the strlen GCC builtin???
 740
 741    function Length (Str : Cstring_Ptr) return Natural is
 742       Len : Integer;
 743
 744    begin
 745       Len := 1;
 746       while Str (Len) /= ASCII.NUL loop
 747          Len := Len + 1;
 748       end loop;
 749
 750       return Len - 1;
 751    end Length;
 752
 753    -------------------
 754    -- Offset_To_Top --
 755    -------------------
 756
 757    function Offset_To_Top
 758      (This : System.Address) return SSE.Storage_Offset
 759    is
 760       Tag_Size : constant SSE.Storage_Count :=
 761         SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
 762
 763       type Storage_Offset_Ptr is access SSE.Storage_Offset;
 764       function To_Storage_Offset_Ptr is
 765         new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
 766
 767       Curr_DT : Dispatch_Table_Ptr;
 768
 769    begin
 770       Curr_DT := DT (To_Tag_Ptr (This).all);
 771
 772       if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then
 773          return To_Storage_Offset_Ptr (This + Tag_Size).all;
 774       else
 775          return Curr_DT.Offset_To_Top;
 776       end if;
 777    end Offset_To_Top;
 778
 779    ------------------------
 780    -- Needs_Finalization --
 781    ------------------------
 782
 783    function Needs_Finalization (T : Tag) return Boolean is
 784       TSD_Ptr : constant Addr_Ptr :=
 785                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 786       TSD     : constant Type_Specific_Data_Ptr :=
 787                   To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 788    begin
 789       return TSD.Needs_Finalization;
 790    end Needs_Finalization;
 791
 792    -----------------
 793    -- Parent_Size --
 794    -----------------
 795
 796    function Parent_Size
 797      (Obj : System.Address;
 798       T   : Tag) return SSE.Storage_Count
 799    is
 800       Parent_Slot : constant Positive := 1;
 801       --  The tag of the parent is always in the first slot of the table of
 802       --  ancestor tags.
 803
 804       TSD_Ptr : constant Addr_Ptr :=
 805                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 806       TSD     : constant Type_Specific_Data_Ptr :=
 807                   To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 808       --  Pointer to the TSD
 809
 810       Parent_Tag     : constant Tag := TSD.Tags_Table (Parent_Slot);
 811       Parent_TSD_Ptr : constant Addr_Ptr :=
 812                          To_Addr_Ptr (To_Address (Parent_Tag)
 813                                        - DT_Typeinfo_Ptr_Size);
 814       Parent_TSD     : constant Type_Specific_Data_Ptr :=
 815                          To_Type_Specific_Data_Ptr (Parent_TSD_Ptr.all);
 816
 817    begin
 818       --  Here we compute the size of the _parent field of the object
 819
 820       return SSE.Storage_Count (Parent_TSD.Size_Func.all (Obj));
 821    end Parent_Size;
 822
 823    ----------------
 824    -- Parent_Tag --
 825    ----------------
 826
 827    function Parent_Tag (T : Tag) return Tag is
 828       TSD_Ptr : Addr_Ptr;
 829       TSD     : Type_Specific_Data_Ptr;
 830
 831    begin
 832       if T = No_Tag then
 833          raise Tag_Error;
 834       end if;
 835
 836       TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 837       TSD     := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 838
 839       --  The Parent_Tag of a root-level tagged type is defined to be No_Tag.
 840       --  The first entry in the Ancestors_Tags array will be null for such
 841       --  a type, but it's better to be explicit about returning No_Tag in
 842       --  this case.
 843
 844       if TSD.Idepth = 0 then
 845          return No_Tag;
 846       else
 847          return TSD.Tags_Table (1);
 848       end if;
 849    end Parent_Tag;
 850
 851    -------------------------------
 852    -- Register_Interface_Offset --
 853    -------------------------------
 854
 855    procedure Register_Interface_Offset
 856      (This         : System.Address;
 857       Interface_T  : Tag;
 858       Is_Static    : Boolean;
 859       Offset_Value : SSE.Storage_Offset;
 860       Offset_Func  : Offset_To_Top_Function_Ptr)
 861    is
 862       Prim_DT     : Dispatch_Table_Ptr;
 863       Iface_Table : Interface_Data_Ptr;
 864
 865    begin
 866       --  "This" points to the primary DT and we must save Offset_Value in
 867       --  the Offset_To_Top field of the corresponding dispatch table.
 868
 869       Prim_DT     := DT (To_Tag_Ptr (This).all);
 870       Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
 871
 872       --  Save Offset_Value in the table of interfaces of the primary DT.
 873       --  This data will be used by the subprogram "Displace" to give support
 874       --  to backward abstract interface type conversions.
 875
 876       --  Register the offset in the table of interfaces
 877
 878       if Iface_Table /= null then
 879          for Id in 1 .. Iface_Table.Nb_Ifaces loop
 880             if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then
 881                if Is_Static or else Offset_Value = 0 then
 882                   Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := True;
 883                   Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value :=
 884                     Offset_Value;
 885                else
 886                   Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False;
 887                   Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func :=
 888                     Offset_Func;
 889                end if;
 890
 891                return;
 892             end if;
 893          end loop;
 894       end if;
 895
 896       --  If we arrive here there is some error in the run-time data structure
 897
 898       raise Program_Error;
 899    end Register_Interface_Offset;
 900
 901    ------------------
 902    -- Register_Tag --
 903    ------------------
 904
 905    procedure Register_Tag (T : Tag) is
 906    begin
 907       External_Tag_HTable.Set (T);
 908    end Register_Tag;
 909
 910    -------------------
 911    -- Secondary_Tag --
 912    -------------------
 913
 914    function Secondary_Tag (T, Iface : Tag) return Tag is
 915       Iface_Table : Interface_Data_Ptr;
 916       Obj_DT      : Dispatch_Table_Ptr;
 917
 918    begin
 919       if not Is_Primary_DT (T) then
 920          raise Program_Error;
 921       end if;
 922
 923       Obj_DT      := DT (T);
 924       Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table;
 925
 926       if Iface_Table /= null then
 927          for Id in 1 .. Iface_Table.Nb_Ifaces loop
 928             if Iface_Table.Ifaces_Table (Id).Iface_Tag = Iface then
 929                return Iface_Table.Ifaces_Table (Id).Secondary_DT;
 930             end if;
 931          end loop;
 932       end if;
 933
 934       --  If the object does not implement the interface we must raise CE
 935
 936       raise Constraint_Error with "invalid interface conversion";
 937    end Secondary_Tag;
 938
 939    ---------------------
 940    -- Set_Entry_Index --
 941    ---------------------
 942
 943    procedure Set_Entry_Index
 944      (T        : Tag;
 945       Position : Positive;
 946       Value    : Positive)
 947    is
 948    begin
 949       SSD (T).SSD_Table (Position).Index := Value;
 950    end Set_Entry_Index;
 951
 952    -----------------------
 953    -- Set_Offset_To_Top --
 954    -----------------------
 955
 956    procedure Set_Dynamic_Offset_To_Top
 957      (This         : System.Address;
 958       Interface_T  : Tag;
 959       Offset_Value : SSE.Storage_Offset;
 960       Offset_Func  : Offset_To_Top_Function_Ptr)
 961    is
 962       Sec_Base : System.Address;
 963       Sec_DT   : Dispatch_Table_Ptr;
 964    begin
 965       --  Save the offset to top field in the secondary dispatch table
 966
 967       if Offset_Value /= 0 then
 968          Sec_Base := This + Offset_Value;
 969          Sec_DT := DT (To_Tag_Ptr (Sec_Base).all);
 970          Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last;
 971       end if;
 972
 973       Register_Interface_Offset
 974         (This, Interface_T, False, Offset_Value, Offset_Func);
 975    end Set_Dynamic_Offset_To_Top;
 976
 977    ----------------------
 978    -- Set_Prim_Op_Kind --
 979    ----------------------
 980
 981    procedure Set_Prim_Op_Kind
 982      (T        : Tag;
 983       Position : Positive;
 984       Value    : Prim_Op_Kind)
 985    is
 986    begin
 987       SSD (T).SSD_Table (Position).Kind := Value;
 988    end Set_Prim_Op_Kind;
 989
 990    ----------------------
 991    -- Type_Is_Abstract --
 992    ----------------------
 993
 994    function Type_Is_Abstract (T : Tag) return Boolean is
 995       TSD_Ptr : Addr_Ptr;
 996       TSD     : Type_Specific_Data_Ptr;
 997
 998    begin
 999       if T = No_Tag then
1000          raise Tag_Error;
1001       end if;
1002
1003       TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
1004       TSD     := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
1005       return TSD.Type_Is_Abstract;
1006    end Type_Is_Abstract;
1007
1008    --------------------
1009    -- Unregister_Tag --
1010    --------------------
1011
1012    procedure Unregister_Tag (T : Tag) is
1013    begin
1014       External_Tag_HTable.Remove (Get_External_Tag (T));
1015    end Unregister_Tag;
1016
1017    ------------------------
1018    -- Wide_Expanded_Name --
1019    ------------------------
1020
1021    WC_Encoding : Character;
1022    pragma Import (C, WC_Encoding, "__gl_wc_encoding");
1023    --  Encoding method for source, as exported by binder
1024
1025    function Wide_Expanded_Name (T : Tag) return Wide_String is
1026       S : constant String := Expanded_Name (T);
1027       W : Wide_String (1 .. S'Length);
1028       L : Natural;
1029    begin
1030       String_To_Wide_String
1031         (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
1032       return W (1 .. L);
1033    end Wide_Expanded_Name;
1034
1035    -----------------------------
1036    -- Wide_Wide_Expanded_Name --
1037    -----------------------------
1038
1039    function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is
1040       S : constant String := Expanded_Name (T);
1041       W : Wide_Wide_String (1 .. S'Length);
1042       L : Natural;
1043    begin
1044       String_To_Wide_Wide_String
1045         (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
1046       return W (1 .. L);
1047    end Wide_Wide_Expanded_Name;
1048
1049 end Ada.Tags;