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;
 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 := 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 we call the function generated by the expander
 355                --  to provide us with this 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                Addr :=
 632                  Integer_Address'Value (External (Addr_First .. Addr_Last));
 633                return To_Tag (Addr);
 634             end if;
 635          end;
 636
 637       --  Handle library-level tagged types
 638
 639       else
 640          --  Make a copy of the string representing the external tag with
 641          --  a null at the end.
 642
 643          Ext_Copy (External'Range) := External;
 644          Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
 645          Res := External_Tag_HTable.Get (Ext_Copy'Address);
 646       end if;
 647
 648       if Res = null then
 649          declare
 650             Msg1 : constant String := "unknown tagged type: ";
 651             Msg2 : String (1 .. Msg1'Length + External'Length);
 652
 653          begin
 654             Msg2 (1 .. Msg1'Length) := Msg1;
 655             Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
 656               External;
 657             Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2);
 658          end;
 659       end if;
 660
 661       return Res;
 662    end Internal_Tag;
 663
 664    ---------------------------------
 665    -- Is_Descendant_At_Same_Level --
 666    ---------------------------------
 667
 668    function Is_Descendant_At_Same_Level
 669      (Descendant : Tag;
 670       Ancestor   : Tag) return Boolean
 671    is
 672       D_TSD_Ptr : constant Addr_Ptr :=
 673                     To_Addr_Ptr (To_Address (Descendant)
 674                                    - DT_Typeinfo_Ptr_Size);
 675       A_TSD_Ptr : constant Addr_Ptr :=
 676                     To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size);
 677       D_TSD     : constant Type_Specific_Data_Ptr :=
 678                     To_Type_Specific_Data_Ptr (D_TSD_Ptr.all);
 679       A_TSD     : constant Type_Specific_Data_Ptr :=
 680                     To_Type_Specific_Data_Ptr (A_TSD_Ptr.all);
 681
 682    begin
 683       return CW_Membership (Descendant, Ancestor)
 684         and then D_TSD.Access_Level = A_TSD.Access_Level;
 685    end Is_Descendant_At_Same_Level;
 686
 687    ------------
 688    -- Length --
 689    ------------
 690
 691    function Length (Str : Cstring_Ptr) return Natural is
 692       Len : Integer;
 693
 694    begin
 695       Len := 1;
 696       while Str (Len) /= ASCII.Nul loop
 697          Len := Len + 1;
 698       end loop;
 699
 700       return Len - 1;
 701    end Length;
 702
 703    -------------------
 704    -- Offset_To_Top --
 705    -------------------
 706
 707    function Offset_To_Top
 708      (This : System.Address) return SSE.Storage_Offset
 709    is
 710       Tag_Size : constant SSE.Storage_Count :=
 711         SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
 712
 713       type Storage_Offset_Ptr is access SSE.Storage_Offset;
 714       function To_Storage_Offset_Ptr is
 715         new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
 716
 717       Curr_DT : Dispatch_Table_Ptr;
 718
 719    begin
 720       Curr_DT := DT (To_Tag_Ptr (This).all);
 721
 722       if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then
 723          return To_Storage_Offset_Ptr (This + Tag_Size).all;
 724       else
 725          return Curr_DT.Offset_To_Top;
 726       end if;
 727    end Offset_To_Top;
 728
 729    -----------------
 730    -- Parent_Size --
 731    -----------------
 732
 733    function Parent_Size
 734      (Obj : System.Address;
 735       T   : Tag) return SSE.Storage_Count
 736    is
 737       Parent_Slot : constant Positive := 1;
 738       --  The tag of the parent is always in the first slot of the table of
 739       --  ancestor tags.
 740
 741       Size_Slot : constant Positive := 1;
 742       --  The pointer to the _size primitive is always in the first slot of
 743       --  the dispatch table.
 744
 745       TSD_Ptr : constant Addr_Ptr :=
 746                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 747       TSD     : constant Type_Specific_Data_Ptr :=
 748                   To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 749       --  Pointer to the TSD
 750
 751       Parent_Tag              : constant Tag := TSD.Tags_Table (Parent_Slot);
 752       Parent_Predef_Prims_Ptr : constant Addr_Ptr :=
 753                                   To_Addr_Ptr (To_Address (Parent_Tag)
 754                                                 - DT_Predef_Prims_Offset);
 755       Parent_Predef_Prims     : constant Predef_Prims_Table_Ptr :=
 756                                   To_Predef_Prims_Table_Ptr
 757                                     (Parent_Predef_Prims_Ptr.all);
 758
 759       --  The tag of the parent type through the dispatch table and its
 760       --  Predef_Prims field.
 761
 762       F : constant Acc_Size :=
 763             To_Acc_Size (Parent_Predef_Prims (Size_Slot));
 764       --  Access to the _size primitive of the parent
 765
 766    begin
 767       --  Here we compute the size of the _parent field of the object
 768
 769       return SSE.Storage_Count (F.all (Obj));
 770    end Parent_Size;
 771
 772    ----------------
 773    -- Parent_Tag --
 774    ----------------
 775
 776    function Parent_Tag (T : Tag) return Tag is
 777       TSD_Ptr : Addr_Ptr;
 778       TSD     : Type_Specific_Data_Ptr;
 779
 780    begin
 781       if T = No_Tag then
 782          raise Tag_Error;
 783       end if;
 784
 785       TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 786       TSD     := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 787
 788       --  The Parent_Tag of a root-level tagged type is defined to be No_Tag.
 789       --  The first entry in the Ancestors_Tags array will be null for such
 790       --  a type, but it's better to be explicit about returning No_Tag in
 791       --  this case.
 792
 793       if TSD.Idepth = 0 then
 794          return No_Tag;
 795       else
 796          return TSD.Tags_Table (1);
 797       end if;
 798    end Parent_Tag;
 799
 800    ------------------
 801    -- Register_Tag --
 802    ------------------
 803
 804    procedure Register_Tag (T : Tag) is
 805    begin
 806       External_Tag_HTable.Set (T);
 807    end Register_Tag;
 808
 809    ---------------------
 810    -- Set_Entry_Index --
 811    ---------------------
 812
 813    procedure Set_Entry_Index
 814      (T        : Tag;
 815       Position : Positive;
 816       Value    : Positive)
 817    is
 818    begin
 819       SSD (T).SSD_Table (Position).Index := Value;
 820    end Set_Entry_Index;
 821
 822    -----------------------
 823    -- Set_Offset_To_Top --
 824    -----------------------
 825
 826    procedure Set_Offset_To_Top
 827      (This         : System.Address;
 828       Interface_T  : Tag;
 829       Is_Static    : Boolean;
 830       Offset_Value : SSE.Storage_Offset;
 831       Offset_Func  : Offset_To_Top_Function_Ptr)
 832    is
 833       Prim_DT     : Dispatch_Table_Ptr;
 834       Sec_Base    : System.Address;
 835       Sec_DT      : Dispatch_Table_Ptr;
 836       Iface_Table : Interface_Data_Ptr;
 837
 838    begin
 839       --  Save the offset to top field in the secondary dispatch table
 840
 841       if Offset_Value /= 0 then
 842          Sec_Base := This + Offset_Value;
 843          Sec_DT   := DT (To_Tag_Ptr (Sec_Base).all);
 844
 845          if Is_Static then
 846             Sec_DT.Offset_To_Top := Offset_Value;
 847          else
 848             Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last;
 849          end if;
 850       end if;
 851
 852       --  "This" points to the primary DT and we must save Offset_Value in
 853       --  the Offset_To_Top field of the corresponding secondary dispatch
 854       --  table.
 855
 856       Prim_DT     := DT (To_Tag_Ptr (This).all);
 857       Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
 858
 859       --  Save Offset_Value in the table of interfaces of the primary DT.
 860       --  This data will be used by the subprogram "Displace" to give support
 861       --  to backward abstract interface type conversions.
 862
 863       --  Register the offset in the table of interfaces
 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 = Interface_T then
 868                Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top :=
 869                  Is_Static;
 870
 871                if Is_Static then
 872                   Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value
 873                     := Offset_Value;
 874                else
 875                   Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func
 876                     := Offset_Func;
 877                end if;
 878
 879                return;
 880             end if;
 881          end loop;
 882       end if;
 883
 884       --  If we arrive here there is some error in the run-time data structure
 885
 886       raise Program_Error;
 887    end Set_Offset_To_Top;
 888
 889    ----------------------
 890    -- Set_Prim_Op_Kind --
 891    ----------------------
 892
 893    procedure Set_Prim_Op_Kind
 894      (T        : Tag;
 895       Position : Positive;
 896       Value    : Prim_Op_Kind)
 897    is
 898    begin
 899       SSD (T).SSD_Table (Position).Kind := Value;
 900    end Set_Prim_Op_Kind;
 901
 902    ------------------------
 903    -- Wide_Expanded_Name --
 904    ------------------------
 905
 906    WC_Encoding : Character;
 907    pragma Import (C, WC_Encoding, "__gl_wc_encoding");
 908    --  Encoding method for source, as exported by binder
 909
 910    function Wide_Expanded_Name (T : Tag) return Wide_String is
 911    begin
 912       return String_To_Wide_String
 913         (Expanded_Name (T), Get_WC_Encoding_Method (WC_Encoding));
 914    end Wide_Expanded_Name;
 915
 916    -----------------------------
 917    -- Wide_Wide_Expanded_Name --
 918    -----------------------------
 919
 920    function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is
 921    begin
 922       return String_To_Wide_Wide_String
 923         (Expanded_Name (T), Get_WC_Encoding_Method (WC_Encoding));
 924    end Wide_Wide_Expanded_Name;
 925
 926 end Ada.Tags;