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