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