gcc/ada/libgnat/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-2017, 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
  35 with System.HTable;
  36 with System.Storage_Elements; use System.Storage_Elements;
  37 with System.WCh_Con;          use System.WCh_Con;
  38 with System.WCh_StW;          use System.WCh_StW;
  39
  40 pragma Elaborate (System.HTable);
  41 --  Elaborate needed instead of Elaborate_All to avoid elaboration cycles
  42 --  when polling is turned on. This is safe because HTable doesn't do anything
  43 --  at elaboration time; it just contains a generic package we want to
  44 --  instantiate.
  45
  46 package body Ada.Tags is
  47
  48    -----------------------
  49    -- Local Subprograms --
  50    -----------------------
  51
  52    function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
  53    --  Given the tag of an object and the tag associated to a type, return
  54    --  true if Obj is in Typ'Class.
  55
  56    function Get_External_Tag (T : Tag) return System.Address;
  57    --  Returns address of a null terminated string containing the external name
  58
  59    function Is_Primary_DT (T : Tag) return Boolean;
  60    --  Given a tag returns True if it has the signature of a primary dispatch
  61    --  table.  This is Inline_Always since it is called from other Inline_
  62    --  Always subprograms where we want no out of line code to be generated.
  63
  64    function IW_Membership
  65      (Descendant_TSD : Type_Specific_Data_Ptr;
  66       T              : Tag) return Boolean;
  67    --  Subsidiary function of IW_Membership and CW_Membership which factorizes
  68    --  the functionality needed to check if a given descendant implements an
  69    --  interface tag T.
  70
  71    function Length (Str : Cstring_Ptr) return Natural;
  72    --  Length of string represented by the given pointer (treating the string
  73    --  as a C-style string, which is Nul terminated). See comment in body
  74    --  explaining why we cannot use the normal strlen built-in.
  75
  76    function OSD (T : Tag) return Object_Specific_Data_Ptr;
  77    --  Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table,
  78    --  retrieve the address of the record containing the Object Specific
  79    --  Data table.
  80
  81    function SSD (T : Tag) return Select_Specific_Data_Ptr;
  82    --  Ada 2005 (AI-251): Given a pointer T to a dispatch Table, retrieves the
  83    --  address of the record containing the Select Specific Data in T's TSD.
  84
  85    pragma Inline_Always (CW_Membership);
  86    pragma Inline_Always (Get_External_Tag);
  87    pragma Inline_Always (Is_Primary_DT);
  88    pragma Inline_Always (OSD);
  89    pragma Inline_Always (SSD);
  90
  91    --  Unchecked conversions
  92
  93    function To_Address is
  94      new Unchecked_Conversion (Cstring_Ptr, System.Address);
  95
  96    function To_Cstring_Ptr is
  97      new Unchecked_Conversion (System.Address, Cstring_Ptr);
  98
  99    --  Disable warnings on possible aliasing problem
 100
 101    function To_Tag is
 102      new Unchecked_Conversion (Integer_Address, Tag);
 103
 104    function To_Addr_Ptr is
 105       new Ada.Unchecked_Conversion (System.Address, Addr_Ptr);
 106
 107    function To_Address is
 108      new Ada.Unchecked_Conversion (Tag, System.Address);
 109
 110    function To_Dispatch_Table_Ptr is
 111       new Ada.Unchecked_Conversion (Tag, Dispatch_Table_Ptr);
 112
 113    function To_Dispatch_Table_Ptr is
 114       new Ada.Unchecked_Conversion (System.Address, Dispatch_Table_Ptr);
 115
 116    function To_Object_Specific_Data_Ptr is
 117      new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr);
 118
 119    function To_Tag_Ptr is
 120      new Ada.Unchecked_Conversion (System.Address, Tag_Ptr);
 121
 122    function To_Type_Specific_Data_Ptr is
 123      new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
 124
 125    -------------------------------
 126    -- Inline_Always Subprograms --
 127    -------------------------------
 128
 129    --  Inline_always subprograms must be placed before their first call to
 130    --  avoid defeating the frontend inlining mechanism and thus ensure the
 131    --  generation of their correct debug info.
 132
 133    -------------------
 134    -- CW_Membership --
 135    -------------------
 136
 137    --  Canonical implementation of Classwide Membership corresponding to:
 138
 139    --     Obj in Typ'Class
 140
 141    --  Each dispatch table contains a reference to a table of ancestors (stored
 142    --  in the first part of the Tags_Table) and a count of the level of
 143    --  inheritance "Idepth".
 144
 145    --  Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
 146    --  contained in the dispatch table referenced by Obj'Tag . Knowing the
 147    --  level of inheritance of both types, this can be computed in constant
 148    --  time by the formula:
 149
 150    --   TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
 151    --     = Typ'tag
 152
 153    function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
 154       Obj_TSD_Ptr : constant Addr_Ptr :=
 155         To_Addr_Ptr (To_Address (Obj_Tag) - DT_Typeinfo_Ptr_Size);
 156       Typ_TSD_Ptr : constant Addr_Ptr :=
 157         To_Addr_Ptr (To_Address (Typ_Tag) - DT_Typeinfo_Ptr_Size);
 158       Obj_TSD     : constant Type_Specific_Data_Ptr :=
 159         To_Type_Specific_Data_Ptr (Obj_TSD_Ptr.all);
 160       Typ_TSD     : constant Type_Specific_Data_Ptr :=
 161         To_Type_Specific_Data_Ptr (Typ_TSD_Ptr.all);
 162       Pos         : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth;
 163    begin
 164       return Pos >= 0 and then Obj_TSD.Tags_Table (Pos) = Typ_Tag;
 165    end CW_Membership;
 166
 167    ----------------------
 168    -- Get_External_Tag --
 169    ----------------------
 170
 171    function Get_External_Tag (T : Tag) return System.Address is
 172       TSD_Ptr : constant Addr_Ptr :=
 173         To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 174       TSD     : constant Type_Specific_Data_Ptr :=
 175         To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 176    begin
 177       return To_Address (TSD.External_Tag);
 178    end Get_External_Tag;
 179
 180    -----------------
 181    -- Is_Abstract --
 182    -----------------
 183
 184    function Is_Abstract (T : Tag) return Boolean is
 185       TSD_Ptr : Addr_Ptr;
 186       TSD     : Type_Specific_Data_Ptr;
 187
 188    begin
 189       if T = No_Tag then
 190          raise Tag_Error;
 191       end if;
 192
 193       TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 194       TSD     := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 195       return TSD.Is_Abstract;
 196    end Is_Abstract;
 197
 198    -------------------
 199    -- Is_Primary_DT --
 200    -------------------
 201
 202    function Is_Primary_DT (T : Tag) return Boolean is
 203    begin
 204       return DT (T).Signature = Primary_DT;
 205    end Is_Primary_DT;
 206
 207    ---------
 208    -- OSD --
 209    ---------
 210
 211    function OSD (T : Tag) return Object_Specific_Data_Ptr is
 212       OSD_Ptr : constant Addr_Ptr :=
 213                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 214    begin
 215       return To_Object_Specific_Data_Ptr (OSD_Ptr.all);
 216    end OSD;
 217
 218    ---------
 219    -- SSD --
 220    ---------
 221
 222    function SSD (T : Tag) return Select_Specific_Data_Ptr is
 223       TSD_Ptr : constant Addr_Ptr :=
 224                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 225       TSD     : constant Type_Specific_Data_Ptr :=
 226                   To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 227    begin
 228       return TSD.SSD;
 229    end SSD;
 230
 231    -------------------------
 232    -- External_Tag_HTable --
 233    -------------------------
 234
 235    type HTable_Headers is range 1 .. 64;
 236
 237    --  The following internal package defines the routines used for the
 238    --  instantiation of a new System.HTable.Static_HTable (see below). See
 239    --  spec in g-htable.ads for details of usage.
 240
 241    package HTable_Subprograms is
 242       procedure Set_HT_Link (T : Tag; Next : Tag);
 243       function  Get_HT_Link (T : Tag) return Tag;
 244       function Hash (F : System.Address) return HTable_Headers;
 245       function Equal (A, B : System.Address) return Boolean;
 246    end HTable_Subprograms;
 247
 248    package External_Tag_HTable is new System.HTable.Static_HTable (
 249      Header_Num => HTable_Headers,
 250      Element    => Dispatch_Table,
 251      Elmt_Ptr   => Tag,
 252      Null_Ptr   => null,
 253      Set_Next   => HTable_Subprograms.Set_HT_Link,
 254      Next       => HTable_Subprograms.Get_HT_Link,
 255      Key        => System.Address,
 256      Get_Key    => Get_External_Tag,
 257      Hash       => HTable_Subprograms.Hash,
 258      Equal      => HTable_Subprograms.Equal);
 259
 260    ------------------------
 261    -- HTable_Subprograms --
 262    ------------------------
 263
 264    --  Bodies of routines for hash table instantiation
 265
 266    package body HTable_Subprograms is
 267
 268       -----------
 269       -- Equal --
 270       -----------
 271
 272       function Equal (A, B : System.Address) return Boolean is
 273          Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
 274          Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
 275          J    : Integer;
 276       begin
 277          J := 1;
 278          loop
 279             if Str1 (J) /= Str2 (J) then
 280                return False;
 281             elsif Str1 (J) = ASCII.NUL then
 282                return True;
 283             else
 284                J := J + 1;
 285             end if;
 286          end loop;
 287       end Equal;
 288
 289       -----------------
 290       -- Get_HT_Link --
 291       -----------------
 292
 293       function Get_HT_Link (T : Tag) return Tag is
 294          TSD_Ptr : constant Addr_Ptr :=
 295                      To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 296          TSD     : constant Type_Specific_Data_Ptr :=
 297                      To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 298       begin
 299          return TSD.HT_Link.all;
 300       end Get_HT_Link;
 301
 302       ----------
 303       -- Hash --
 304       ----------
 305
 306       function Hash (F : System.Address) return HTable_Headers is
 307          function H is new System.HTable.Hash (HTable_Headers);
 308          Str : constant Cstring_Ptr    := To_Cstring_Ptr (F);
 309          Res : constant HTable_Headers := H (Str (1 .. Length (Str)));
 310       begin
 311          return Res;
 312       end Hash;
 313
 314       -----------------
 315       -- Set_HT_Link --
 316       -----------------
 317
 318       procedure Set_HT_Link (T : Tag; Next : Tag) is
 319          TSD_Ptr : constant Addr_Ptr :=
 320                      To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 321          TSD     : constant Type_Specific_Data_Ptr :=
 322                      To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 323       begin
 324          TSD.HT_Link.all := Next;
 325       end Set_HT_Link;
 326
 327    end HTable_Subprograms;
 328
 329    ------------------
 330    -- Base_Address --
 331    ------------------
 332
 333    function Base_Address (This : System.Address) return System.Address is
 334    begin
 335       return This + Offset_To_Top (This);
 336    end Base_Address;
 337
 338    ---------------
 339    -- Check_TSD --
 340    ---------------
 341
 342    procedure Check_TSD (TSD : Type_Specific_Data_Ptr) is
 343       T : Tag;
 344
 345       E_Tag_Len : constant Integer := Length (TSD.External_Tag);
 346       E_Tag     : String (1 .. E_Tag_Len);
 347       for E_Tag'Address use TSD.External_Tag.all'Address;
 348       pragma Import (Ada, E_Tag);
 349
 350       Dup_Ext_Tag : constant String := "duplicated external tag """;
 351
 352    begin
 353       --  Verify that the external tag of this TSD is not registered in the
 354       --  runtime hash table.
 355
 356       T := External_Tag_HTable.Get (To_Address (TSD.External_Tag));
 357
 358       if T /= null then
 359
 360          --  Avoid concatenation, as it is not allowed in no run time mode
 361
 362          declare
 363             Msg : String (1 .. Dup_Ext_Tag'Length + E_Tag_Len + 1);
 364          begin
 365             Msg (1 .. Dup_Ext_Tag'Length) := Dup_Ext_Tag;
 366             Msg (Dup_Ext_Tag'Length + 1 .. Dup_Ext_Tag'Length + E_Tag_Len) :=
 367               E_Tag;
 368             Msg (Msg'Last) := '"';
 369             raise Program_Error with Msg;
 370          end;
 371       end if;
 372    end Check_TSD;
 373
 374    --------------------
 375    -- Descendant_Tag --
 376    --------------------
 377
 378    function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
 379       Int_Tag : constant Tag := Internal_Tag (External);
 380    begin
 381       if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
 382          raise Tag_Error;
 383       else
 384          return Int_Tag;
 385       end if;
 386    end Descendant_Tag;
 387
 388    --------------
 389    -- Displace --
 390    --------------
 391
 392    function Displace (This : System.Address; T : Tag) return System.Address is
 393       Iface_Table : Interface_Data_Ptr;
 394       Obj_Base    : System.Address;
 395       Obj_DT      : Dispatch_Table_Ptr;
 396       Obj_DT_Tag  : Tag;
 397
 398    begin
 399       if System."=" (This, System.Null_Address) then
 400          return System.Null_Address;
 401       end if;
 402
 403       Obj_Base    := Base_Address (This);
 404       Obj_DT_Tag  := To_Tag_Ptr (Obj_Base).all;
 405       Obj_DT      := DT (To_Tag_Ptr (Obj_Base).all);
 406       Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table;
 407
 408       if Iface_Table /= null then
 409          for Id in 1 .. Iface_Table.Nb_Ifaces loop
 410             if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then
 411
 412                --  Case of Static value of Offset_To_Top
 413
 414                if Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top then
 415                   Obj_Base := Obj_Base -
 416                     Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value;
 417
 418                --  Otherwise call the function generated by the expander to
 419                --  provide the value.
 420
 421                else
 422                   Obj_Base := Obj_Base -
 423                     Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func.all
 424                       (Obj_Base);
 425                end if;
 426
 427                return Obj_Base;
 428             end if;
 429          end loop;
 430       end if;
 431
 432       --  Check if T is an immediate ancestor. This is required to handle
 433       --  conversion of class-wide interfaces to tagged types.
 434
 435       if CW_Membership (Obj_DT_Tag, T) then
 436          return Obj_Base;
 437       end if;
 438
 439       --  If the object does not implement the interface we must raise CE
 440
 441       raise Constraint_Error with "invalid interface conversion";
 442    end Displace;
 443
 444    --------
 445    -- DT --
 446    --------
 447
 448    function DT (T : Tag) return Dispatch_Table_Ptr is
 449       Offset : constant SSE.Storage_Offset :=
 450                  To_Dispatch_Table_Ptr (T).Prims_Ptr'Position;
 451    begin
 452       return To_Dispatch_Table_Ptr (To_Address (T) - Offset);
 453    end DT;
 454
 455    -------------------
 456    -- IW_Membership --
 457    -------------------
 458
 459    function IW_Membership
 460      (Descendant_TSD : Type_Specific_Data_Ptr;
 461       T              : Tag) return Boolean
 462    is
 463       Iface_Table : Interface_Data_Ptr;
 464
 465    begin
 466       Iface_Table := Descendant_TSD.Interfaces_Table;
 467
 468       if Iface_Table /= null then
 469          for Id in 1 .. Iface_Table.Nb_Ifaces loop
 470             if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then
 471                return True;
 472             end if;
 473          end loop;
 474       end if;
 475
 476       --  Look for the tag in the ancestor tags table. This is required for:
 477       --     Iface_CW in Typ'Class
 478
 479       for Id in 0 .. Descendant_TSD.Idepth loop
 480          if Descendant_TSD.Tags_Table (Id) = T then
 481             return True;
 482          end if;
 483       end loop;
 484
 485       return False;
 486    end IW_Membership;
 487
 488    -------------------
 489    -- IW_Membership --
 490    -------------------
 491
 492    --  Canonical implementation of Classwide Membership corresponding to:
 493
 494    --     Obj in Iface'Class
 495
 496    --  Each dispatch table contains a table with the tags of all the
 497    --  implemented interfaces.
 498
 499    --  Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
 500    --  that are contained in the dispatch table referenced by Obj'Tag.
 501
 502    function IW_Membership (This : System.Address; T : Tag) return Boolean is
 503       Obj_Base : System.Address;
 504       Obj_DT   : Dispatch_Table_Ptr;
 505       Obj_TSD  : Type_Specific_Data_Ptr;
 506
 507    begin
 508       Obj_Base := Base_Address (This);
 509       Obj_DT   := DT (To_Tag_Ptr (Obj_Base).all);
 510       Obj_TSD  := To_Type_Specific_Data_Ptr (Obj_DT.TSD);
 511
 512       return IW_Membership (Obj_TSD, T);
 513    end IW_Membership;
 514
 515    -------------------
 516    -- Expanded_Name --
 517    -------------------
 518
 519    function Expanded_Name (T : Tag) return String is
 520       Result  : Cstring_Ptr;
 521       TSD_Ptr : Addr_Ptr;
 522       TSD     : Type_Specific_Data_Ptr;
 523
 524    begin
 525       if T = No_Tag then
 526          raise Tag_Error;
 527       end if;
 528
 529       TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 530       TSD     := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 531       Result  := TSD.Expanded_Name;
 532       return Result (1 .. Length (Result));
 533    end Expanded_Name;
 534
 535    ------------------
 536    -- External_Tag --
 537    ------------------
 538
 539    function External_Tag (T : Tag) return String is
 540       Result  : Cstring_Ptr;
 541       TSD_Ptr : Addr_Ptr;
 542       TSD     : Type_Specific_Data_Ptr;
 543
 544    begin
 545       if T = No_Tag then
 546          raise Tag_Error;
 547       end if;
 548
 549       TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 550       TSD     := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 551       Result  := TSD.External_Tag;
 552       return Result (1 .. Length (Result));
 553    end External_Tag;
 554
 555    ---------------------
 556    -- Get_Entry_Index --
 557    ---------------------
 558
 559    function Get_Entry_Index (T : Tag; Position : Positive) return Positive is
 560    begin
 561       return SSD (T).SSD_Table (Position).Index;
 562    end Get_Entry_Index;
 563
 564    ----------------------
 565    -- Get_Prim_Op_Kind --
 566    ----------------------
 567
 568    function Get_Prim_Op_Kind
 569      (T        : Tag;
 570       Position : Positive) return Prim_Op_Kind
 571    is
 572    begin
 573       return SSD (T).SSD_Table (Position).Kind;
 574    end Get_Prim_Op_Kind;
 575
 576    ----------------------
 577    -- Get_Offset_Index --
 578    ----------------------
 579
 580    function Get_Offset_Index
 581      (T        : Tag;
 582       Position : Positive) return Positive
 583    is
 584    begin
 585       if Is_Primary_DT (T) then
 586          return Position;
 587       else
 588          return OSD (T).OSD_Table (Position);
 589       end if;
 590    end Get_Offset_Index;
 591
 592    ---------------------
 593    -- Get_Tagged_Kind --
 594    ---------------------
 595
 596    function Get_Tagged_Kind (T : Tag) return Tagged_Kind is
 597    begin
 598       return DT (T).Tag_Kind;
 599    end Get_Tagged_Kind;
 600
 601    -----------------------------
 602    -- Interface_Ancestor_Tags --
 603    -----------------------------
 604
 605    function Interface_Ancestor_Tags (T : Tag) return Tag_Array is
 606       TSD_Ptr     : constant Addr_Ptr :=
 607                       To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 608       TSD         : constant Type_Specific_Data_Ptr :=
 609                       To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 610       Iface_Table : constant Interface_Data_Ptr := TSD.Interfaces_Table;
 611
 612    begin
 613       if Iface_Table = null then
 614          declare
 615             Table : Tag_Array (1 .. 0);
 616          begin
 617             return Table;
 618          end;
 619
 620       else
 621          declare
 622             Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces);
 623          begin
 624             for J in 1 .. Iface_Table.Nb_Ifaces loop
 625                Table (J) := Iface_Table.Ifaces_Table (J).Iface_Tag;
 626             end loop;
 627
 628             return Table;
 629          end;
 630       end if;
 631    end Interface_Ancestor_Tags;
 632
 633    ------------------
 634    -- Internal_Tag --
 635    ------------------
 636
 637    --  Internal tags have the following format:
 638    --    "Internal tag at 16#ADDRESS#: <full-name-of-tagged-type>"
 639
 640    Internal_Tag_Header : constant String    := "Internal tag at ";
 641    Header_Separator    : constant Character := '#';
 642
 643    function Internal_Tag (External : String) return Tag is
 644       pragma Unsuppress (All_Checks);
 645       --  To make T'Class'Input robust in the case of bad data
 646
 647       Res : Tag := null;
 648
 649    begin
 650       --  Raise Tag_Error for empty strings and very long strings. This makes
 651       --  T'Class'Input robust in the case of bad data, for example
 652       --
 653       --    String (123456789..1234)
 654       --
 655       --  The limit of 10,000 characters is arbitrary, but is unlikely to be
 656       --  exceeded by legitimate external tag names.
 657
 658       if External'Length not in 1 .. 10_000 then
 659          raise Tag_Error;
 660       end if;
 661
 662       --  Handle locally defined tagged types
 663
 664       if External'Length > Internal_Tag_Header'Length
 665         and then
 666           External (External'First ..
 667                       External'First + Internal_Tag_Header'Length - 1) =
 668                                                         Internal_Tag_Header
 669       then
 670          declare
 671             Addr_First : constant Natural :=
 672                            External'First + Internal_Tag_Header'Length;
 673             Addr_Last  : Natural;
 674             Addr       : Integer_Address;
 675
 676          begin
 677             --  Search the second separator (#) to identify the address
 678
 679             Addr_Last := Addr_First;
 680
 681             for J in 1 .. 2 loop
 682                while Addr_Last <= External'Last
 683                  and then External (Addr_Last) /= Header_Separator
 684                loop
 685                   Addr_Last := Addr_Last + 1;
 686                end loop;
 687
 688                --  Skip the first separator
 689
 690                if J = 1 then
 691                   Addr_Last := Addr_Last + 1;
 692                end if;
 693             end loop;
 694
 695             if Addr_Last <= External'Last then
 696
 697                --  Protect the run-time against wrong internal tags. We
 698                --  cannot use exception handlers here because it would
 699                --  disable the use of this run-time compiling with
 700                --  restriction No_Exception_Handler.
 701
 702                declare
 703                   C         : Character;
 704                   Wrong_Tag : Boolean := False;
 705
 706                begin
 707                   if External (Addr_First) /= '1'
 708                     or else External (Addr_First + 1) /= '6'
 709                     or else External (Addr_First + 2) /= '#'
 710                   then
 711                      Wrong_Tag := True;
 712
 713                   else
 714                      for J in Addr_First + 3 .. Addr_Last - 1 loop
 715                         C := External (J);
 716
 717                         if not (C in '0' .. '9')
 718                           and then not (C in 'A' .. 'F')
 719                           and then not (C in 'a' .. 'f')
 720                         then
 721                            Wrong_Tag := True;
 722                            exit;
 723                         end if;
 724                      end loop;
 725                   end if;
 726
 727                   --  Convert the numeric value into a tag
 728
 729                   if not Wrong_Tag then
 730                      Addr := Integer_Address'Value
 731                                (External (Addr_First .. Addr_Last));
 732
 733                      --  Internal tags never have value 0
 734
 735                      if Addr /= 0 then
 736                         return To_Tag (Addr);
 737                      end if;
 738                   end if;
 739                end;
 740             end if;
 741          end;
 742
 743       --  Handle library-level tagged types
 744
 745       else
 746          --  Make NUL-terminated copy of external tag string
 747
 748          declare
 749             Ext_Copy : aliased String (External'First .. External'Last + 1);
 750             pragma Assert (Ext_Copy'Length > 1); -- See Length check at top
 751          begin
 752             Ext_Copy (External'Range) := External;
 753             Ext_Copy (Ext_Copy'Last)  := ASCII.NUL;
 754             Res := External_Tag_HTable.Get (Ext_Copy'Address);
 755          end;
 756       end if;
 757
 758       if Res = null then
 759          declare
 760             Msg1 : constant String := "unknown tagged type: ";
 761             Msg2 : String (1 .. Msg1'Length + External'Length);
 762
 763          begin
 764             Msg2 (1 .. Msg1'Length) := Msg1;
 765             Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
 766               External;
 767             Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2);
 768          end;
 769       end if;
 770
 771       return Res;
 772    end Internal_Tag;
 773
 774    ---------------------------------
 775    -- Is_Descendant_At_Same_Level --
 776    ---------------------------------
 777
 778    function Is_Descendant_At_Same_Level
 779      (Descendant : Tag;
 780       Ancestor   : Tag) return Boolean
 781    is
 782    begin
 783       if Descendant = Ancestor then
 784          return True;
 785
 786       else
 787          declare
 788             D_TSD_Ptr : constant Addr_Ptr :=
 789               To_Addr_Ptr (To_Address (Descendant) - DT_Typeinfo_Ptr_Size);
 790             A_TSD_Ptr : constant Addr_Ptr :=
 791               To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size);
 792             D_TSD     : constant Type_Specific_Data_Ptr :=
 793               To_Type_Specific_Data_Ptr (D_TSD_Ptr.all);
 794             A_TSD     : constant Type_Specific_Data_Ptr :=
 795               To_Type_Specific_Data_Ptr (A_TSD_Ptr.all);
 796          begin
 797             return
 798               D_TSD.Access_Level = A_TSD.Access_Level
 799                 and then (CW_Membership (Descendant, Ancestor)
 800                            or else IW_Membership (D_TSD, Ancestor));
 801          end;
 802       end if;
 803    end Is_Descendant_At_Same_Level;
 804
 805    ------------
 806    -- Length --
 807    ------------
 808
 809    --  Note: This unit is used in the Ravenscar runtime library, so it cannot
 810    --  depend on System.CTRL. Furthermore, this happens on CPUs where the GCC
 811    --  intrinsic strlen may not be available, so we need to recode our own Ada
 812    --  version here.
 813
 814    function Length (Str : Cstring_Ptr) return Natural is
 815       Len : Integer;
 816
 817    begin
 818       Len := 1;
 819       while Str (Len) /= ASCII.NUL loop
 820          Len := Len + 1;
 821       end loop;
 822
 823       return Len - 1;
 824    end Length;
 825
 826    -------------------
 827    -- Offset_To_Top --
 828    -------------------
 829
 830    function Offset_To_Top
 831      (This : System.Address) return SSE.Storage_Offset
 832    is
 833       Tag_Size : constant SSE.Storage_Count :=
 834         SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
 835
 836       type Storage_Offset_Ptr is access SSE.Storage_Offset;
 837       function To_Storage_Offset_Ptr is
 838         new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
 839
 840       Curr_DT : Dispatch_Table_Ptr;
 841
 842    begin
 843       Curr_DT := DT (To_Tag_Ptr (This).all);
 844
 845       --  See the documentation of Dispatch_Table_Wrapper.Offset_To_Top
 846
 847       if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then
 848
 849          --  The parent record type has variable-size components, so the
 850          --  instance-specific offset is stored in the tagged record, right
 851          --  after the reference to Curr_DT (which is a secondary dispatch
 852          --  table).
 853
 854          return To_Storage_Offset_Ptr (This + Tag_Size).all;
 855
 856       else
 857          --  The offset is compile-time known, so it is simply stored in the
 858          --  Offset_To_Top field.
 859
 860          return Curr_DT.Offset_To_Top;
 861       end if;
 862    end Offset_To_Top;
 863
 864    ------------------------
 865    -- Needs_Finalization --
 866    ------------------------
 867
 868    function Needs_Finalization (T : Tag) return Boolean is
 869       TSD_Ptr : constant Addr_Ptr :=
 870                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 871       TSD     : constant Type_Specific_Data_Ptr :=
 872                   To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 873    begin
 874       return TSD.Needs_Finalization;
 875    end Needs_Finalization;
 876
 877    -----------------
 878    -- Parent_Size --
 879    -----------------
 880
 881    function Parent_Size
 882      (Obj : System.Address;
 883       T   : Tag) return SSE.Storage_Count
 884    is
 885       Parent_Slot : constant Positive := 1;
 886       --  The tag of the parent is always in the first slot of the table of
 887       --  ancestor tags.
 888
 889       TSD_Ptr : constant Addr_Ptr :=
 890                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 891       TSD     : constant Type_Specific_Data_Ptr :=
 892                   To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 893       --  Pointer to the TSD
 894
 895       Parent_Tag     : constant Tag := TSD.Tags_Table (Parent_Slot);
 896       Parent_TSD_Ptr : constant Addr_Ptr :=
 897         To_Addr_Ptr (To_Address (Parent_Tag) - DT_Typeinfo_Ptr_Size);
 898       Parent_TSD     : constant Type_Specific_Data_Ptr :=
 899         To_Type_Specific_Data_Ptr (Parent_TSD_Ptr.all);
 900
 901    begin
 902       --  Here we compute the size of the _parent field of the object
 903
 904       return SSE.Storage_Count (Parent_TSD.Size_Func.all (Obj));
 905    end Parent_Size;
 906
 907    ----------------
 908    -- Parent_Tag --
 909    ----------------
 910
 911    function Parent_Tag (T : Tag) return Tag is
 912       TSD_Ptr : Addr_Ptr;
 913       TSD     : Type_Specific_Data_Ptr;
 914
 915    begin
 916       if T = No_Tag then
 917          raise Tag_Error;
 918       end if;
 919
 920       TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 921       TSD     := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 922
 923       --  The Parent_Tag of a root-level tagged type is defined to be No_Tag.
 924       --  The first entry in the Ancestors_Tags array will be null for such
 925       --  a type, but it's better to be explicit about returning No_Tag in
 926       --  this case.
 927
 928       if TSD.Idepth = 0 then
 929          return No_Tag;
 930       else
 931          return TSD.Tags_Table (1);
 932       end if;
 933    end Parent_Tag;
 934
 935    -------------------------------
 936    -- Register_Interface_Offset --
 937    -------------------------------
 938
 939    procedure Register_Interface_Offset
 940      (Prim_T       : Tag;
 941       Interface_T  : Tag;
 942       Is_Static    : Boolean;
 943       Offset_Value : SSE.Storage_Offset;
 944       Offset_Func  : Offset_To_Top_Function_Ptr)
 945    is
 946       Prim_DT     : constant Dispatch_Table_Ptr := DT (Prim_T);
 947       Iface_Table : constant Interface_Data_Ptr :=
 948                       To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
 949
 950    begin
 951       --  Save Offset_Value in the table of interfaces of the primary DT.
 952       --  This data will be used by the subprogram "Displace" to give support
 953       --  to backward abstract interface type conversions.
 954
 955       --  Register the offset in the table of interfaces
 956
 957       if Iface_Table /= null then
 958          for Id in 1 .. Iface_Table.Nb_Ifaces loop
 959             if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then
 960                if Is_Static or else Offset_Value = 0 then
 961                   Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := True;
 962                   Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value  :=
 963                     Offset_Value;
 964                else
 965                   Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False;
 966                   Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func   :=
 967                     Offset_Func;
 968                end if;
 969
 970                return;
 971             end if;
 972          end loop;
 973       end if;
 974
 975       --  If we arrive here there is some error in the run-time data structure
 976
 977       raise Program_Error;
 978    end Register_Interface_Offset;
 979
 980    ------------------
 981    -- Register_Tag --
 982    ------------------
 983
 984    procedure Register_Tag (T : Tag) is
 985    begin
 986       External_Tag_HTable.Set (T);
 987    end Register_Tag;
 988
 989    -------------------
 990    -- Secondary_Tag --
 991    -------------------
 992
 993    function Secondary_Tag (T, Iface : Tag) return Tag is
 994       Iface_Table : Interface_Data_Ptr;
 995       Obj_DT      : Dispatch_Table_Ptr;
 996
 997    begin
 998       if not Is_Primary_DT (T) then
 999          raise Program_Error;
1000       end if;
1001
1002       Obj_DT      := DT (T);
1003       Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table;
1004
1005       if Iface_Table /= null then
1006          for Id in 1 .. Iface_Table.Nb_Ifaces loop
1007             if Iface_Table.Ifaces_Table (Id).Iface_Tag = Iface then
1008                return Iface_Table.Ifaces_Table (Id).Secondary_DT;
1009             end if;
1010          end loop;
1011       end if;
1012
1013       --  If the object does not implement the interface we must raise CE
1014
1015       raise Constraint_Error with "invalid interface conversion";
1016    end Secondary_Tag;
1017
1018    ---------------------
1019    -- Set_Entry_Index --
1020    ---------------------
1021
1022    procedure Set_Entry_Index
1023      (T        : Tag;
1024       Position : Positive;
1025       Value    : Positive)
1026    is
1027    begin
1028       SSD (T).SSD_Table (Position).Index := Value;
1029    end Set_Entry_Index;
1030
1031    -----------------------
1032    -- Set_Offset_To_Top --
1033    -----------------------
1034
1035    procedure Set_Dynamic_Offset_To_Top
1036      (This         : System.Address;
1037       Prim_T       : Tag;
1038       Interface_T  : Tag;
1039       Offset_Value : SSE.Storage_Offset;
1040       Offset_Func  : Offset_To_Top_Function_Ptr)
1041    is
1042       Sec_Base : System.Address;
1043       Sec_DT   : Dispatch_Table_Ptr;
1044
1045    begin
1046       --  Save the offset to top field in the secondary dispatch table
1047
1048       if Offset_Value /= 0 then
1049          Sec_Base := This - Offset_Value;
1050          Sec_DT := DT (To_Tag_Ptr (Sec_Base).all);
1051          Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last;
1052       end if;
1053
1054       Register_Interface_Offset
1055         (Prim_T, Interface_T, False, Offset_Value, Offset_Func);
1056    end Set_Dynamic_Offset_To_Top;
1057
1058    ----------------------
1059    -- Set_Prim_Op_Kind --
1060    ----------------------
1061
1062    procedure Set_Prim_Op_Kind
1063      (T        : Tag;
1064       Position : Positive;
1065       Value    : Prim_Op_Kind)
1066    is
1067    begin
1068       SSD (T).SSD_Table (Position).Kind := Value;
1069    end Set_Prim_Op_Kind;
1070
1071    --------------------
1072    -- Unregister_Tag --
1073    --------------------
1074
1075    procedure Unregister_Tag (T : Tag) is
1076    begin
1077       External_Tag_HTable.Remove (Get_External_Tag (T));
1078    end Unregister_Tag;
1079
1080    ------------------------
1081    -- Wide_Expanded_Name --
1082    ------------------------
1083
1084    WC_Encoding : Character;
1085    pragma Import (C, WC_Encoding, "__gl_wc_encoding");
1086    --  Encoding method for source, as exported by binder
1087
1088    function Wide_Expanded_Name (T : Tag) return Wide_String is
1089       S : constant String := Expanded_Name (T);
1090       W : Wide_String (1 .. S'Length);
1091       L : Natural;
1092    begin
1093       String_To_Wide_String
1094         (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
1095       return W (1 .. L);
1096    end Wide_Expanded_Name;
1097
1098    -----------------------------
1099    -- Wide_Wide_Expanded_Name --
1100    -----------------------------
1101
1102    function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is
1103       S : constant String := Expanded_Name (T);
1104       W : Wide_Wide_String (1 .. S'Length);
1105       L : Natural;
1106    begin
1107       String_To_Wide_Wide_String
1108         (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
1109       return W (1 .. L);
1110    end Wide_Wide_Expanded_Name;
1111
1112 end Ada.Tags;