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