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    -- Descendant_Tag --
 323    --------------------
 324
 325    function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
 326       Int_Tag : constant Tag := Internal_Tag (External);
 327
 328    begin
 329       if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
 330          raise Tag_Error;
 331       end if;
 332
 333       return Int_Tag;
 334    end Descendant_Tag;
 335
 336    --------------
 337    -- Displace --
 338    --------------
 339
 340    function Displace
 341      (This : System.Address;
 342       T    : Tag) return System.Address
 343    is
 344       Iface_Table : Interface_Data_Ptr;
 345       Obj_Base    : System.Address;
 346       Obj_DT      : Dispatch_Table_Ptr;
 347       Obj_DT_Tag  : Tag;
 348
 349    begin
 350       if System."=" (This, System.Null_Address) then
 351          return System.Null_Address;
 352       end if;
 353
 354       Obj_Base    := Base_Address (This);
 355       Obj_DT_Tag  := To_Tag_Ptr (Obj_Base).all;
 356       Obj_DT      := DT (To_Tag_Ptr (Obj_Base).all);
 357       Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table;
 358
 359       if Iface_Table /= null then
 360          for Id in 1 .. Iface_Table.Nb_Ifaces loop
 361             if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then
 362
 363                --  Case of Static value of Offset_To_Top
 364
 365                if Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top then
 366                   Obj_Base := Obj_Base +
 367                     Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value;
 368
 369                --  Otherwise call the function generated by the expander to
 370                --  provide the value.
 371
 372                else
 373                   Obj_Base := Obj_Base +
 374                     Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func.all
 375                       (Obj_Base);
 376                end if;
 377
 378                return Obj_Base;
 379             end if;
 380          end loop;
 381       end if;
 382
 383       --  Check if T is an immediate ancestor. This is required to handle
 384       --  conversion of class-wide interfaces to tagged types.
 385
 386       if CW_Membership (Obj_DT_Tag, T) then
 387          return Obj_Base;
 388       end if;
 389
 390       --  If the object does not implement the interface we must raise CE
 391
 392       raise Constraint_Error with "invalid interface conversion";
 393    end Displace;
 394
 395    --------
 396    -- DT --
 397    --------
 398
 399    function DT (T : Tag) return Dispatch_Table_Ptr is
 400       Offset : constant SSE.Storage_Offset :=
 401                  To_Dispatch_Table_Ptr (T).Prims_Ptr'Position;
 402    begin
 403       return To_Dispatch_Table_Ptr (To_Address (T) - Offset);
 404    end DT;
 405
 406    -------------------
 407    -- IW_Membership --
 408    -------------------
 409
 410    --  Canonical implementation of Classwide Membership corresponding to:
 411
 412    --     Obj in Iface'Class
 413
 414    --  Each dispatch table contains a table with the tags of all the
 415    --  implemented interfaces.
 416
 417    --  Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
 418    --  that are contained in the dispatch table referenced by Obj'Tag.
 419
 420    function IW_Membership (This : System.Address; T : Tag) return Boolean is
 421       Iface_Table : Interface_Data_Ptr;
 422       Obj_Base    : System.Address;
 423       Obj_DT      : Dispatch_Table_Ptr;
 424       Obj_TSD     : Type_Specific_Data_Ptr;
 425
 426    begin
 427       Obj_Base    := Base_Address (This);
 428       Obj_DT      := DT (To_Tag_Ptr (Obj_Base).all);
 429       Obj_TSD     := To_Type_Specific_Data_Ptr (Obj_DT.TSD);
 430       Iface_Table := Obj_TSD.Interfaces_Table;
 431
 432       if Iface_Table /= null then
 433          for Id in 1 .. Iface_Table.Nb_Ifaces loop
 434             if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then
 435                return True;
 436             end if;
 437          end loop;
 438       end if;
 439
 440       --  Look for the tag in the ancestor tags table. This is required for:
 441       --     Iface_CW in Typ'Class
 442
 443       for Id in 0 .. Obj_TSD.Idepth loop
 444          if Obj_TSD.Tags_Table (Id) = T then
 445             return True;
 446          end if;
 447       end loop;
 448
 449       return False;
 450    end IW_Membership;
 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    -- Secondary_Tag --
 851    -------------------
 852
 853    function Secondary_Tag (T, Iface : Tag) return Tag is
 854       Iface_Table : Interface_Data_Ptr;
 855       Obj_DT      : Dispatch_Table_Ptr;
 856
 857    begin
 858       if not Is_Primary_DT (T) then
 859          raise Program_Error;
 860       end if;
 861
 862       Obj_DT      := DT (T);
 863       Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table;
 864
 865       if Iface_Table /= null then
 866          for Id in 1 .. Iface_Table.Nb_Ifaces loop
 867             if Iface_Table.Ifaces_Table (Id).Iface_Tag = Iface then
 868                return Iface_Table.Ifaces_Table (Id).Secondary_DT;
 869             end if;
 870          end loop;
 871       end if;
 872
 873       --  If the object does not implement the interface we must raise CE
 874
 875       raise Constraint_Error with "invalid interface conversion";
 876    end Secondary_Tag;
 877
 878    ---------------------
 879    -- Set_Entry_Index --
 880    ---------------------
 881
 882    procedure Set_Entry_Index
 883      (T        : Tag;
 884       Position : Positive;
 885       Value    : Positive)
 886    is
 887    begin
 888       SSD (T).SSD_Table (Position).Index := Value;
 889    end Set_Entry_Index;
 890
 891    -----------------------
 892    -- Set_Offset_To_Top --
 893    -----------------------
 894
 895    procedure Set_Offset_To_Top
 896      (This         : System.Address;
 897       Interface_T  : Tag;
 898       Is_Static    : Boolean;
 899       Offset_Value : SSE.Storage_Offset;
 900       Offset_Func  : Offset_To_Top_Function_Ptr)
 901    is
 902       Prim_DT     : Dispatch_Table_Ptr;
 903       Sec_Base    : System.Address;
 904       Sec_DT      : Dispatch_Table_Ptr;
 905       Iface_Table : Interface_Data_Ptr;
 906
 907    begin
 908       --  Save the offset to top field in the secondary dispatch table
 909
 910       if Offset_Value /= 0 then
 911          Sec_Base := This + Offset_Value;
 912          Sec_DT   := DT (To_Tag_Ptr (Sec_Base).all);
 913
 914          if Is_Static then
 915             Sec_DT.Offset_To_Top := Offset_Value;
 916          else
 917             Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last;
 918          end if;
 919       end if;
 920
 921       --  "This" points to the primary DT and we must save Offset_Value in
 922       --  the Offset_To_Top field of the corresponding secondary dispatch
 923       --  table.
 924
 925       Prim_DT     := DT (To_Tag_Ptr (This).all);
 926       Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
 927
 928       --  Save Offset_Value in the table of interfaces of the primary DT.
 929       --  This data will be used by the subprogram "Displace" to give support
 930       --  to backward abstract interface type conversions.
 931
 932       --  Register the offset in the table of interfaces
 933
 934       if Iface_Table /= null then
 935          for Id in 1 .. Iface_Table.Nb_Ifaces loop
 936             if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then
 937                Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top :=
 938                  Is_Static;
 939
 940                if Is_Static then
 941                   Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value
 942                     := Offset_Value;
 943                else
 944                   Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func
 945                     := Offset_Func;
 946                end if;
 947
 948                return;
 949             end if;
 950          end loop;
 951       end if;
 952
 953       --  If we arrive here there is some error in the run-time data structure
 954
 955       raise Program_Error;
 956    end Set_Offset_To_Top;
 957
 958    ----------------------
 959    -- Set_Prim_Op_Kind --
 960    ----------------------
 961
 962    procedure Set_Prim_Op_Kind
 963      (T        : Tag;
 964       Position : Positive;
 965       Value    : Prim_Op_Kind)
 966    is
 967    begin
 968       SSD (T).SSD_Table (Position).Kind := Value;
 969    end Set_Prim_Op_Kind;
 970
 971    ------------------------
 972    -- Wide_Expanded_Name --
 973    ------------------------
 974
 975    WC_Encoding : Character;
 976    pragma Import (C, WC_Encoding, "__gl_wc_encoding");
 977    --  Encoding method for source, as exported by binder
 978
 979    function Wide_Expanded_Name (T : Tag) return Wide_String is
 980       S : constant String := Expanded_Name (T);
 981       W : Wide_String (1 .. S'Length);
 982       L : Natural;
 983    begin
 984       String_To_Wide_String
 985         (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
 986       return W (1 .. L);
 987    end Wide_Expanded_Name;
 988
 989    -----------------------------
 990    -- Wide_Wide_Expanded_Name --
 991    -----------------------------
 992
 993    function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is
 994       S : constant String := Expanded_Name (T);
 995       W : Wide_Wide_String (1 .. S'Length);
 996       L : Natural;
 997    begin
 998       String_To_Wide_Wide_String
 999         (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
1000       return W (1 .. L);
1001    end Wide_Wide_Expanded_Name;
1002
1003 end Ada.Tags;