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-2010, 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    -- Descendant_Tag --
 308    --------------------
 309
 310    function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
 311       Int_Tag : constant Tag := Internal_Tag (External);
 312
 313    begin
 314       if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
 315          raise Tag_Error;
 316       end if;
 317
 318       return Int_Tag;
 319    end Descendant_Tag;
 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    -- Expanded_Name --
 439    -------------------
 440
 441    function Expanded_Name (T : Tag) return String is
 442       Result  : Cstring_Ptr;
 443       TSD_Ptr : Addr_Ptr;
 444       TSD     : Type_Specific_Data_Ptr;
 445
 446    begin
 447       if T = No_Tag then
 448          raise Tag_Error;
 449       end if;
 450
 451       TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 452       TSD     := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 453       Result  := TSD.Expanded_Name;
 454       return Result (1 .. Length (Result));
 455    end Expanded_Name;
 456
 457    ------------------
 458    -- External_Tag --
 459    ------------------
 460
 461    function External_Tag (T : Tag) return String is
 462       Result  : Cstring_Ptr;
 463       TSD_Ptr : Addr_Ptr;
 464       TSD     : Type_Specific_Data_Ptr;
 465
 466    begin
 467       if T = No_Tag then
 468          raise Tag_Error;
 469       end if;
 470
 471       TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 472       TSD     := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 473       Result  := TSD.External_Tag;
 474       return Result (1 .. Length (Result));
 475    end External_Tag;
 476
 477    ---------------------
 478    -- Get_Entry_Index --
 479    ---------------------
 480
 481    function Get_Entry_Index (T : Tag; Position : Positive) return Positive is
 482    begin
 483       return SSD (T).SSD_Table (Position).Index;
 484    end Get_Entry_Index;
 485
 486    ----------------------
 487    -- Get_Prim_Op_Kind --
 488    ----------------------
 489
 490    function Get_Prim_Op_Kind
 491      (T        : Tag;
 492       Position : Positive) return Prim_Op_Kind
 493    is
 494    begin
 495       return SSD (T).SSD_Table (Position).Kind;
 496    end Get_Prim_Op_Kind;
 497
 498    ----------------------
 499    -- Get_Offset_Index --
 500    ----------------------
 501
 502    function Get_Offset_Index
 503      (T        : Tag;
 504       Position : Positive) return Positive
 505    is
 506    begin
 507       if Is_Primary_DT (T) then
 508          return Position;
 509       else
 510          return OSD (T).OSD_Table (Position);
 511       end if;
 512    end Get_Offset_Index;
 513
 514    -------------------
 515    -- Get_RC_Offset --
 516    -------------------
 517
 518    function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is
 519       TSD_Ptr : constant Addr_Ptr :=
 520                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 521       TSD     : constant Type_Specific_Data_Ptr :=
 522                   To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 523    begin
 524       return TSD.RC_Offset;
 525    end Get_RC_Offset;
 526
 527    ---------------------
 528    -- Get_Tagged_Kind --
 529    ---------------------
 530
 531    function Get_Tagged_Kind (T : Tag) return Tagged_Kind is
 532    begin
 533       return DT (T).Tag_Kind;
 534    end Get_Tagged_Kind;
 535
 536    -----------------------------
 537    -- Interface_Ancestor_Tags --
 538    -----------------------------
 539
 540    function Interface_Ancestor_Tags (T : Tag) return Tag_Array is
 541       TSD_Ptr     : constant Addr_Ptr :=
 542                       To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 543       TSD         : constant Type_Specific_Data_Ptr :=
 544                       To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 545       Iface_Table : constant Interface_Data_Ptr := TSD.Interfaces_Table;
 546
 547    begin
 548       if Iface_Table = null then
 549          declare
 550             Table : Tag_Array (1 .. 0);
 551          begin
 552             return Table;
 553          end;
 554       else
 555          declare
 556             Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces);
 557          begin
 558             for J in 1 .. Iface_Table.Nb_Ifaces loop
 559                Table (J) := Iface_Table.Ifaces_Table (J).Iface_Tag;
 560             end loop;
 561
 562             return Table;
 563          end;
 564       end if;
 565    end Interface_Ancestor_Tags;
 566
 567    ------------------
 568    -- Internal_Tag --
 569    ------------------
 570
 571    --  Internal tags have the following format:
 572    --    "Internal tag at 16#ADDRESS#: <full-name-of-tagged-type>"
 573
 574    Internal_Tag_Header : constant String    := "Internal tag at ";
 575    Header_Separator    : constant Character := '#';
 576
 577    function Internal_Tag (External : String) return Tag is
 578       Ext_Copy : aliased String (External'First .. External'Last + 1);
 579       Res      : Tag := null;
 580
 581    begin
 582       --  Handle locally defined tagged types
 583
 584       if External'Length > Internal_Tag_Header'Length
 585         and then
 586          External (External'First ..
 587                      External'First + Internal_Tag_Header'Length - 1)
 588            = Internal_Tag_Header
 589       then
 590          declare
 591             Addr_First : constant Natural :=
 592                            External'First + Internal_Tag_Header'Length;
 593             Addr_Last  : Natural;
 594             Addr       : Integer_Address;
 595
 596          begin
 597             --  Search the second separator (#) to identify the address
 598
 599             Addr_Last := Addr_First;
 600
 601             for J in 1 .. 2 loop
 602                while Addr_Last <= External'Last
 603                  and then External (Addr_Last) /= Header_Separator
 604                loop
 605                   Addr_Last := Addr_Last + 1;
 606                end loop;
 607
 608                --  Skip the first separator
 609
 610                if J = 1 then
 611                   Addr_Last := Addr_Last + 1;
 612                end if;
 613             end loop;
 614
 615             if Addr_Last <= External'Last then
 616
 617                --  Protect the run-time against wrong internal tags. We
 618                --  cannot use exception handlers here because it would
 619                --  disable the use of this run-time compiling with
 620                --  restriction No_Exception_Handler.
 621
 622                declare
 623                   C         : Character;
 624                   Wrong_Tag : Boolean := False;
 625
 626                begin
 627                   if External (Addr_First) /= '1'
 628                     or else External (Addr_First + 1) /= '6'
 629                     or else External (Addr_First + 2) /= '#'
 630                   then
 631                      Wrong_Tag := True;
 632
 633                   else
 634                      for J in Addr_First + 3 .. Addr_Last - 1 loop
 635                         C := External (J);
 636
 637                         if not (C in '0' .. '9')
 638                           and then not (C in 'A' .. 'F')
 639                           and then not (C in 'a' .. 'f')
 640                         then
 641                            Wrong_Tag := True;
 642                            exit;
 643                         end if;
 644                      end loop;
 645                   end if;
 646
 647                   --  Convert the numeric value into a tag
 648
 649                   if not Wrong_Tag then
 650                      Addr := Integer_Address'Value
 651                                (External (Addr_First .. Addr_Last));
 652
 653                      --  Internal tags never have value 0
 654
 655                      if Addr /= 0 then
 656                         return To_Tag (Addr);
 657                      end if;
 658                   end if;
 659                end;
 660             end if;
 661          end;
 662
 663       --  Handle library-level tagged types
 664
 665       else
 666          --  Make NUL-terminated copy of external tag string
 667
 668          Ext_Copy (External'Range) := External;
 669          Ext_Copy (Ext_Copy'Last)  := ASCII.NUL;
 670          Res := External_Tag_HTable.Get (Ext_Copy'Address);
 671       end if;
 672
 673       if Res = null then
 674          declare
 675             Msg1 : constant String := "unknown tagged type: ";
 676             Msg2 : String (1 .. Msg1'Length + External'Length);
 677
 678          begin
 679             Msg2 (1 .. Msg1'Length) := Msg1;
 680             Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
 681               External;
 682             Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2);
 683          end;
 684       end if;
 685
 686       return Res;
 687    end Internal_Tag;
 688
 689    ---------------------------------
 690    -- Is_Descendant_At_Same_Level --
 691    ---------------------------------
 692
 693    function Is_Descendant_At_Same_Level
 694      (Descendant : Tag;
 695       Ancestor   : Tag) return Boolean
 696    is
 697       D_TSD_Ptr : constant Addr_Ptr :=
 698                     To_Addr_Ptr (To_Address (Descendant)
 699                                    - DT_Typeinfo_Ptr_Size);
 700       A_TSD_Ptr : constant Addr_Ptr :=
 701                     To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size);
 702       D_TSD     : constant Type_Specific_Data_Ptr :=
 703                     To_Type_Specific_Data_Ptr (D_TSD_Ptr.all);
 704       A_TSD     : constant Type_Specific_Data_Ptr :=
 705                     To_Type_Specific_Data_Ptr (A_TSD_Ptr.all);
 706
 707    begin
 708       return CW_Membership (Descendant, Ancestor)
 709         and then D_TSD.Access_Level = A_TSD.Access_Level;
 710    end Is_Descendant_At_Same_Level;
 711
 712    ------------
 713    -- Length --
 714    ------------
 715
 716    function Length (Str : Cstring_Ptr) return Natural is
 717       Len : Integer;
 718
 719    begin
 720       Len := 1;
 721       while Str (Len) /= ASCII.NUL loop
 722          Len := Len + 1;
 723       end loop;
 724
 725       return Len - 1;
 726    end Length;
 727
 728    -------------------
 729    -- Offset_To_Top --
 730    -------------------
 731
 732    function Offset_To_Top
 733      (This : System.Address) return SSE.Storage_Offset
 734    is
 735       Tag_Size : constant SSE.Storage_Count :=
 736         SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
 737
 738       type Storage_Offset_Ptr is access SSE.Storage_Offset;
 739       function To_Storage_Offset_Ptr is
 740         new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
 741
 742       Curr_DT : Dispatch_Table_Ptr;
 743
 744    begin
 745       Curr_DT := DT (To_Tag_Ptr (This).all);
 746
 747       if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then
 748          return To_Storage_Offset_Ptr (This + Tag_Size).all;
 749       else
 750          return Curr_DT.Offset_To_Top;
 751       end if;
 752    end Offset_To_Top;
 753
 754    -----------------
 755    -- Parent_Size --
 756    -----------------
 757
 758    function Parent_Size
 759      (Obj : System.Address;
 760       T   : Tag) return SSE.Storage_Count
 761    is
 762       Parent_Slot : constant Positive := 1;
 763       --  The tag of the parent is always in the first slot of the table of
 764       --  ancestor tags.
 765
 766       TSD_Ptr : constant Addr_Ptr :=
 767                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 768       TSD     : constant Type_Specific_Data_Ptr :=
 769                   To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 770       --  Pointer to the TSD
 771
 772       Parent_Tag     : constant Tag := TSD.Tags_Table (Parent_Slot);
 773       Parent_TSD_Ptr : constant Addr_Ptr :=
 774                          To_Addr_Ptr (To_Address (Parent_Tag)
 775                                        - DT_Typeinfo_Ptr_Size);
 776       Parent_TSD     : constant Type_Specific_Data_Ptr :=
 777                          To_Type_Specific_Data_Ptr (Parent_TSD_Ptr.all);
 778
 779    begin
 780       --  Here we compute the size of the _parent field of the object
 781
 782       return SSE.Storage_Count (Parent_TSD.Size_Func.all (Obj));
 783    end Parent_Size;
 784
 785    ----------------
 786    -- Parent_Tag --
 787    ----------------
 788
 789    function Parent_Tag (T : Tag) return Tag is
 790       TSD_Ptr : Addr_Ptr;
 791       TSD     : Type_Specific_Data_Ptr;
 792
 793    begin
 794       if T = No_Tag then
 795          raise Tag_Error;
 796       end if;
 797
 798       TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 799       TSD     := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 800
 801       --  The Parent_Tag of a root-level tagged type is defined to be No_Tag.
 802       --  The first entry in the Ancestors_Tags array will be null for such
 803       --  a type, but it's better to be explicit about returning No_Tag in
 804       --  this case.
 805
 806       if TSD.Idepth = 0 then
 807          return No_Tag;
 808       else
 809          return TSD.Tags_Table (1);
 810       end if;
 811    end Parent_Tag;
 812
 813    -------------------------------
 814    -- Register_Interface_Offset --
 815    -------------------------------
 816
 817    procedure Register_Interface_Offset
 818      (This         : System.Address;
 819       Interface_T  : Tag;
 820       Is_Static    : Boolean;
 821       Offset_Value : SSE.Storage_Offset;
 822       Offset_Func  : Offset_To_Top_Function_Ptr)
 823    is
 824       Prim_DT     : Dispatch_Table_Ptr;
 825       Iface_Table : Interface_Data_Ptr;
 826
 827    begin
 828       --  "This" points to the primary DT and we must save Offset_Value in
 829       --  the Offset_To_Top field of the corresponding dispatch table.
 830
 831       Prim_DT     := DT (To_Tag_Ptr (This).all);
 832       Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
 833
 834       --  Save Offset_Value in the table of interfaces of the primary DT.
 835       --  This data will be used by the subprogram "Displace" to give support
 836       --  to backward abstract interface type conversions.
 837
 838       --  Register the offset in the table of interfaces
 839
 840       if Iface_Table /= null then
 841          for Id in 1 .. Iface_Table.Nb_Ifaces loop
 842             if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then
 843                if Is_Static or else Offset_Value = 0 then
 844                   Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := True;
 845                   Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value :=
 846                     Offset_Value;
 847                else
 848                   Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False;
 849                   Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func :=
 850                     Offset_Func;
 851                end if;
 852
 853                return;
 854             end if;
 855          end loop;
 856       end if;
 857
 858       --  If we arrive here there is some error in the run-time data structure
 859
 860       raise Program_Error;
 861    end Register_Interface_Offset;
 862
 863    ------------------
 864    -- Register_Tag --
 865    ------------------
 866
 867    procedure Register_Tag (T : Tag) is
 868    begin
 869       External_Tag_HTable.Set (T);
 870    end Register_Tag;
 871
 872    -------------------
 873    -- Secondary_Tag --
 874    -------------------
 875
 876    function Secondary_Tag (T, Iface : Tag) return Tag is
 877       Iface_Table : Interface_Data_Ptr;
 878       Obj_DT      : Dispatch_Table_Ptr;
 879
 880    begin
 881       if not Is_Primary_DT (T) then
 882          raise Program_Error;
 883       end if;
 884
 885       Obj_DT      := DT (T);
 886       Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table;
 887
 888       if Iface_Table /= null then
 889          for Id in 1 .. Iface_Table.Nb_Ifaces loop
 890             if Iface_Table.Ifaces_Table (Id).Iface_Tag = Iface then
 891                return Iface_Table.Ifaces_Table (Id).Secondary_DT;
 892             end if;
 893          end loop;
 894       end if;
 895
 896       --  If the object does not implement the interface we must raise CE
 897
 898       raise Constraint_Error with "invalid interface conversion";
 899    end Secondary_Tag;
 900
 901    ---------------------
 902    -- Set_Entry_Index --
 903    ---------------------
 904
 905    procedure Set_Entry_Index
 906      (T        : Tag;
 907       Position : Positive;
 908       Value    : Positive)
 909    is
 910    begin
 911       SSD (T).SSD_Table (Position).Index := Value;
 912    end Set_Entry_Index;
 913
 914    -----------------------
 915    -- Set_Offset_To_Top --
 916    -----------------------
 917
 918    procedure Set_Dynamic_Offset_To_Top
 919      (This         : System.Address;
 920       Interface_T  : Tag;
 921       Offset_Value : SSE.Storage_Offset;
 922       Offset_Func  : Offset_To_Top_Function_Ptr)
 923    is
 924       Sec_Base : System.Address;
 925       Sec_DT   : Dispatch_Table_Ptr;
 926    begin
 927       --  Save the offset to top field in the secondary dispatch table
 928
 929       if Offset_Value /= 0 then
 930          Sec_Base := This + Offset_Value;
 931          Sec_DT := DT (To_Tag_Ptr (Sec_Base).all);
 932          Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last;
 933       end if;
 934
 935       Register_Interface_Offset
 936         (This, Interface_T, False, Offset_Value, Offset_Func);
 937    end Set_Dynamic_Offset_To_Top;
 938
 939    ----------------------
 940    -- Set_Prim_Op_Kind --
 941    ----------------------
 942
 943    procedure Set_Prim_Op_Kind
 944      (T        : Tag;
 945       Position : Positive;
 946       Value    : Prim_Op_Kind)
 947    is
 948    begin
 949       SSD (T).SSD_Table (Position).Kind := Value;
 950    end Set_Prim_Op_Kind;
 951
 952    ----------------------
 953    -- Type_Is_Abstract --
 954    ----------------------
 955
 956    function Type_Is_Abstract (T : Tag) return Boolean is
 957       TSD_Ptr : Addr_Ptr;
 958       TSD     : Type_Specific_Data_Ptr;
 959
 960    begin
 961       if T = No_Tag then
 962          raise Tag_Error;
 963       end if;
 964
 965       TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 966       TSD     := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 967       return TSD.Type_Is_Abstract;
 968    end Type_Is_Abstract;
 969
 970    ------------------------
 971    -- Wide_Expanded_Name --
 972    ------------------------
 973
 974    WC_Encoding : Character;
 975    pragma Import (C, WC_Encoding, "__gl_wc_encoding");
 976    --  Encoding method for source, as exported by binder
 977
 978    function Wide_Expanded_Name (T : Tag) return Wide_String is
 979       S : constant String := Expanded_Name (T);
 980       W : Wide_String (1 .. S'Length);
 981       L : Natural;
 982    begin
 983       String_To_Wide_String
 984         (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
 985       return W (1 .. L);
 986    end Wide_Expanded_Name;
 987
 988    -----------------------------
 989    -- Wide_Wide_Expanded_Name --
 990    -----------------------------
 991
 992    function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is
 993       S : constant String := Expanded_Name (T);
 994       W : Wide_Wide_String (1 .. S'Length);
 995       L : Natural;
 996    begin
 997       String_To_Wide_Wide_String
 998         (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
 999       return W (1 .. L);
1000    end Wide_Wide_Expanded_Name;
1001
1002 end Ada.Tags;