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-2005 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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 System.HTable;
  36 with System.Storage_Elements; use System.Storage_Elements;
  37
  38 pragma Elaborate_All (System.HTable);
  39
  40 package body Ada.Tags is
  41
  42 --  Structure of the GNAT Dispatch Table
  43
  44 --           +-----------------------+
  45 --           |     Offset_To_Top     |
  46 --           +-----------------------+
  47 --           | Typeinfo_Ptr/TSD_Ptr  |----> Type Specific Data
  48 --  Tag ---> +-----------------------+      +-------------------+
  49 --           |        table of       |      | inheritance depth |
  50 --           :     primitive ops     :      +-------------------+
  51 --           |        pointers       |      |   expanded name   |
  52 --           +-----------------------+      +-------------------+
  53 --                                          |   external tag    |
  54 --                                          +-------------------+
  55 --                                          |   Hash table link |
  56 --                                          +-------------------+
  57 --                                          | Remotely Callable |
  58 --                                          +-------------------+
  59 --                                          | Rec Ctrler offset |
  60 --                                          +-------------------+
  61 --                                          |  Num_Interfaces   |
  62 --                                          +-------------------+
  63 --                                          | table of          |
  64 --                                          :   ancestor        :
  65 --                                          |      tags         |
  66 --                                          +-------------------+
  67 --                                          | table of          |
  68 --                                          |   interface       |
  69 --                                          |      tags         |
  70 --                                          +-------------------+
  71
  72    subtype Cstring is String (Positive);
  73    type Cstring_Ptr is access all Cstring;
  74
  75    type Tag_Table is array (Natural range <>) of Tag;
  76    pragma Suppress_Initialization (Tag_Table);
  77    pragma Suppress (Index_Check, On => Tag_Table);
  78    --  We suppress index checks because the declared size in the record below
  79    --  is a dummy size of one (see below).
  80
  81    type Type_Specific_Data is record
  82       Idepth            : Natural;
  83       Access_Level      : Natural;
  84       Expanded_Name     : Cstring_Ptr;
  85       External_Tag      : Cstring_Ptr;
  86       HT_Link           : Tag;
  87       Remotely_Callable : Boolean;
  88       RC_Offset         : SSE.Storage_Offset;
  89       Num_Interfaces    : Natural;
  90       Tags_Table        : Tag_Table (Natural);
  91
  92       --  The size of the Tags_Table array actually depends on the tagged type
  93       --  to which it applies. The compiler ensures that has enough space to
  94       --  store all the entries of the two tables phisically stored there: the
  95       --  "table of ancestor tags" and the "table of interface tags". For this
  96       --  purpose we are using the same mechanism as for the Prims_Ptr array in
  97       --  the Dispatch_Table record. See comments below for more details.
  98
  99    end record;
 100
 101    type Dispatch_Table is record
 102       --  Offset_To_Top : Natural;
 103       --  Typeinfo_Ptr  : System.Address; -- Currently TSD is also here???
 104       Prims_Ptr : Address_Array (Positive);
 105    end record;
 106
 107    --  Note on the commented out fields of the Dispatch_Table
 108    --
 109    --  According to the C++ ABI the components Offset_To_Top and Typeinfo_Ptr
 110    --  are stored just "before" the dispatch table (that is, the Prims_Ptr
 111    --  table), and they are referenced with negative offsets referring to the
 112    --  base of the dispatch table. The _Tag (or the VTable_Ptr in C++ termi-
 113    --  nology) must point to the base of the virtual table, just after these
 114    --  components, to point to the Prims_Ptr table. For this purpose the
 115    --  expander generates a Prims_Ptr table that has enough space for these
 116    --  additional components, and generates code that displaces the _Tag to
 117    --  point after these components.
 118
 119    --  The size of the Prims_Ptr array actually depends on the tagged type to
 120    --  which it applies. For each tagged type, the expander computes the
 121    --  actual array size, allocates the Dispatch_Table record accordingly, and
 122    --  generates code that displaces the base of the record after the
 123    --  Typeinfo_Ptr component. For this reason the first two components have
 124    --  been commented in the previous declaration. The access to these
 125    --  components is done by means of local functions.
 126    --
 127    --  To avoid the use of discriminants to define the actual size of the
 128    --  dispatch table, we used to declare the tag as a pointer to a record
 129    --  that contains an arbitrary array of addresses, using Positive as its
 130    --  index. This ensures that there are never range checks when accessing
 131    --  the dispatch table, but it prevents GDB from displaying tagged types
 132    --  properly. A better approach is to declare this record type as holding a
 133    --  small number of addresses, and to explicitly suppress checks on it.
 134    --
 135    --  Note that in both cases, this type is never allocated, and serves only
 136    --  to declare the corresponding access type.
 137
 138    ---------------------------------------------
 139    -- Unchecked Conversions for String Fields --
 140    ---------------------------------------------
 141
 142    function To_Address is
 143      new Unchecked_Conversion (Cstring_Ptr, System.Address);
 144
 145    function To_Cstring_Ptr is
 146      new Unchecked_Conversion (System.Address, Cstring_Ptr);
 147
 148    ------------------------------------------------
 149    -- Unchecked Conversions for other components --
 150    ------------------------------------------------
 151
 152    type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset;
 153
 154    function To_Storage_Offset_Ptr is
 155       new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
 156
 157    -----------------------
 158    -- Local Subprograms --
 159    -----------------------
 160
 161    function Length (Str : Cstring_Ptr) return Natural;
 162    --  Length of string represented by the given pointer (treating the string
 163    --  as a C-style string, which is Nul terminated).
 164
 165    function Offset_To_Top
 166      (T : Tag) return System.Storage_Elements.Storage_Offset;
 167    --  Returns the current value of the offset_to_top component available in
 168    --  the prologue of the dispatch table.
 169
 170    function Typeinfo_Ptr (T : Tag) return System.Address;
 171    --  Returns the current value of the typeinfo_ptr component available in
 172    --  the prologue of the dispatch table.
 173
 174    pragma Unreferenced (Typeinfo_Ptr);
 175    --  These functions will be used for full compatibility with the C++ ABI
 176
 177    -------------------------
 178    -- External_Tag_HTable --
 179    -------------------------
 180
 181    type HTable_Headers is range 1 .. 64;
 182
 183    --  The following internal package defines the routines used for the
 184    --  instantiation of a new System.HTable.Static_HTable (see below). See
 185    --  spec in g-htable.ads for details of usage.
 186
 187    package HTable_Subprograms is
 188       procedure Set_HT_Link (T : Tag; Next : Tag);
 189       function  Get_HT_Link (T : Tag) return Tag;
 190       function Hash (F : System.Address) return HTable_Headers;
 191       function Equal (A, B : System.Address) return Boolean;
 192    end HTable_Subprograms;
 193
 194    package External_Tag_HTable is new System.HTable.Static_HTable (
 195      Header_Num => HTable_Headers,
 196      Element    => Dispatch_Table,
 197      Elmt_Ptr   => Tag,
 198      Null_Ptr   => null,
 199      Set_Next   => HTable_Subprograms.Set_HT_Link,
 200      Next       => HTable_Subprograms.Get_HT_Link,
 201      Key        => System.Address,
 202      Get_Key    => Get_External_Tag,
 203      Hash       => HTable_Subprograms.Hash,
 204      Equal      => HTable_Subprograms.Equal);
 205
 206    ------------------------
 207    -- HTable_Subprograms --
 208    ------------------------
 209
 210    --  Bodies of routines for hash table instantiation
 211
 212    package body HTable_Subprograms is
 213
 214    -----------
 215    -- Equal --
 216    -----------
 217
 218       function Equal (A, B : System.Address) return Boolean is
 219          Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
 220          Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
 221          J    : Integer := 1;
 222
 223       begin
 224          loop
 225             if Str1 (J) /= Str2 (J) then
 226                return False;
 227
 228             elsif Str1 (J) = ASCII.NUL then
 229                return True;
 230
 231             else
 232                J := J + 1;
 233             end if;
 234          end loop;
 235       end Equal;
 236
 237       -----------------
 238       -- Get_HT_Link --
 239       -----------------
 240
 241       function Get_HT_Link (T : Tag) return Tag is
 242       begin
 243          return TSD (T).HT_Link;
 244       end Get_HT_Link;
 245
 246       ----------
 247       -- Hash --
 248       ----------
 249
 250       function Hash (F : System.Address) return HTable_Headers is
 251          function H is new System.HTable.Hash (HTable_Headers);
 252          Str : constant Cstring_Ptr    := To_Cstring_Ptr (F);
 253          Res : constant HTable_Headers := H (Str (1 .. Length (Str)));
 254       begin
 255          return Res;
 256       end Hash;
 257
 258       -----------------
 259       -- Set_HT_Link --
 260       -----------------
 261
 262       procedure Set_HT_Link (T : Tag; Next : Tag) is
 263       begin
 264          TSD (T).HT_Link := Next;
 265       end Set_HT_Link;
 266
 267    end HTable_Subprograms;
 268
 269    -------------------
 270    -- CW_Membership --
 271    -------------------
 272
 273    --  Canonical implementation of Classwide Membership corresponding to:
 274
 275    --     Obj in Typ'Class
 276
 277    --  Each dispatch table contains a reference to a table of ancestors (stored
 278    --  in the first part of the Tags_Table) and a count of the level of
 279    --  inheritance "Idepth".
 280
 281    --  Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
 282    --  contained in the dispatch table referenced by Obj'Tag . Knowing the
 283    --  level of inheritance of both types, this can be computed in constant
 284    --  time by the formula:
 285
 286    --   Obj'tag.TSD.Ancestor_Tags (Obj'tag.TSD.Idepth - Typ'tag.TSD.Idepth)
 287    --     = Typ'tag
 288
 289    function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
 290       Pos : constant Integer := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
 291    begin
 292       return Pos >= 0 and then TSD (Obj_Tag).Tags_Table (Pos) = Typ_Tag;
 293    end CW_Membership;
 294
 295    -------------------
 296    -- IW_Membership --
 297    -------------------
 298
 299    --  Canonical implementation of Classwide Membership corresponding to:
 300
 301    --     Obj in Iface'Class
 302
 303    --  Each dispatch table contains a table with the tags of all the
 304    --  implemented interfaces.
 305
 306    --  Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
 307    --  that are contained in the dispatch table referenced by Obj'Tag.
 308
 309    function IW_Membership
 310      (This      : System.Address;
 311       Iface_Tag : Tag) return Boolean
 312    is
 313       T        : constant Tag := To_Tag_Ptr (This).all;
 314       Obj_Base : constant System.Address := This - Offset_To_Top (T);
 315       T_Base   : constant Tag := To_Tag_Ptr (Obj_Base).all;
 316
 317       Obj_TSD  : constant Type_Specific_Data_Ptr := TSD (T_Base);
 318       Last_Id  : constant Natural := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces;
 319       Id       : Natural;
 320
 321    begin
 322       if Obj_TSD.Num_Interfaces > 0 then
 323          Id := Obj_TSD.Idepth + 1;
 324          loop
 325             if Obj_TSD.Tags_Table (Id) = Iface_Tag then
 326                return True;
 327             end if;
 328
 329             Id := Id + 1;
 330             exit when Id > Last_Id;
 331          end loop;
 332       end if;
 333
 334       return False;
 335    end IW_Membership;
 336
 337    --------------------
 338    -- Descendant_Tag --
 339    --------------------
 340
 341    function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
 342       Int_Tag : constant Tag := Internal_Tag (External);
 343
 344    begin
 345       if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
 346          raise Tag_Error;
 347       end if;
 348
 349       return Int_Tag;
 350    end Descendant_Tag;
 351
 352    -------------------
 353    -- Expanded_Name --
 354    -------------------
 355
 356    function Expanded_Name (T : Tag) return String is
 357       Result : Cstring_Ptr;
 358
 359    begin
 360       if T = No_Tag then
 361          raise Tag_Error;
 362       end if;
 363
 364       Result := TSD (T).Expanded_Name;
 365       return Result (1 .. Length (Result));
 366    end Expanded_Name;
 367
 368    ------------------
 369    -- External_Tag --
 370    ------------------
 371
 372    function External_Tag (T : Tag) return String is
 373       Result : Cstring_Ptr;
 374    begin
 375       if T = No_Tag then
 376          raise Tag_Error;
 377       end if;
 378
 379       Result := TSD (T).External_Tag;
 380
 381       return Result (1 .. Length (Result));
 382    end External_Tag;
 383
 384    ----------------------
 385    -- Get_Access_Level --
 386    ----------------------
 387
 388    function Get_Access_Level (T : Tag) return Natural is
 389    begin
 390       return TSD (T).Access_Level;
 391    end Get_Access_Level;
 392
 393    ----------------------
 394    -- Get_External_Tag --
 395    ----------------------
 396
 397    function Get_External_Tag (T : Tag) return System.Address is
 398    begin
 399       return To_Address (TSD (T).External_Tag);
 400    end Get_External_Tag;
 401
 402    -------------------------
 403    -- Get_Prim_Op_Address --
 404    -------------------------
 405
 406    function Get_Prim_Op_Address
 407      (T        : Tag;
 408       Position : Positive) return System.Address is
 409    begin
 410       return T.Prims_Ptr (Position);
 411    end Get_Prim_Op_Address;
 412
 413    -------------------
 414    -- Get_RC_Offset --
 415    -------------------
 416
 417    function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is
 418    begin
 419       return TSD (T).RC_Offset;
 420    end Get_RC_Offset;
 421
 422    ---------------------------
 423    -- Get_Remotely_Callable --
 424    ---------------------------
 425
 426    function Get_Remotely_Callable (T : Tag) return Boolean is
 427    begin
 428       return TSD (T).Remotely_Callable;
 429    end Get_Remotely_Callable;
 430
 431    ----------------
 432    -- Inherit_DT --
 433    ----------------
 434
 435    procedure Inherit_DT
 436     (Old_T       : Tag;
 437      New_T       : Tag;
 438      Entry_Count : Natural)
 439    is
 440    begin
 441       if Old_T /= null then
 442          New_T.Prims_Ptr (1 .. Entry_Count) :=
 443            Old_T.Prims_Ptr (1 .. Entry_Count);
 444       end if;
 445    end Inherit_DT;
 446
 447    -----------------
 448    -- Inherit_TSD --
 449    -----------------
 450
 451    procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag) is
 452       New_TSD_Ptr : constant Type_Specific_Data_Ptr := TSD (New_Tag);
 453       Old_TSD_Ptr : Type_Specific_Data_Ptr;
 454
 455    begin
 456       if Old_Tag /= null then
 457          Old_TSD_Ptr := TSD (Old_Tag);
 458          New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1;
 459          New_TSD_Ptr.Num_Interfaces := Old_TSD_Ptr.Num_Interfaces;
 460
 461          --  Copy the "table of ancestor tags" plus the "table of interfaces"
 462          --  of the parent
 463
 464          New_TSD_Ptr.Tags_Table
 465            (1 .. New_TSD_Ptr.Idepth + New_TSD_Ptr.Num_Interfaces)
 466            := Old_TSD_Ptr.Tags_Table
 467                 (0 .. Old_TSD_Ptr.Idepth + Old_TSD_Ptr.Num_Interfaces);
 468       else
 469          New_TSD_Ptr.Idepth         := 0;
 470          New_TSD_Ptr.Num_Interfaces := 0;
 471       end if;
 472
 473       New_TSD_Ptr.Tags_Table (0) := New_Tag;
 474    end Inherit_TSD;
 475
 476    ------------------
 477    -- Internal_Tag --
 478    ------------------
 479
 480    function Internal_Tag (External : String) return Tag is
 481       Ext_Copy : aliased String (External'First .. External'Last + 1);
 482       Res      : Tag;
 483
 484    begin
 485       --  Make a copy of the string representing the external tag with
 486       --  a null at the end
 487
 488       Ext_Copy (External'Range) := External;
 489       Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
 490       Res := External_Tag_HTable.Get (Ext_Copy'Address);
 491
 492       if Res = null then
 493          declare
 494             Msg1 : constant String := "unknown tagged type: ";
 495             Msg2 : String (1 .. Msg1'Length + External'Length);
 496          begin
 497             Msg2 (1 .. Msg1'Length) := Msg1;
 498             Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
 499               External;
 500             Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2);
 501          end;
 502       end if;
 503
 504       return Res;
 505    end Internal_Tag;
 506
 507    ---------------------------------
 508    -- Is_Descendant_At_Same_Level --
 509    ---------------------------------
 510
 511    function Is_Descendant_At_Same_Level
 512      (Descendant : Tag;
 513       Ancestor   : Tag) return Boolean
 514    is
 515    begin
 516       return CW_Membership (Descendant, Ancestor)
 517         and then TSD (Descendant).Access_Level = TSD (Ancestor).Access_Level;
 518    end Is_Descendant_At_Same_Level;
 519
 520    ------------
 521    -- Length --
 522    ------------
 523
 524    function Length (Str : Cstring_Ptr) return Natural is
 525       Len : Integer := 1;
 526
 527    begin
 528       while Str (Len) /= ASCII.Nul loop
 529          Len := Len + 1;
 530       end loop;
 531
 532       return Len - 1;
 533    end Length;
 534
 535    -------------------
 536    -- Offset_To_Top --
 537    -------------------
 538
 539    function Offset_To_Top
 540      (T : Tag) return System.Storage_Elements.Storage_Offset
 541    is
 542       Offset_To_Top_Ptr : constant Storage_Offset_Ptr :=
 543                             To_Storage_Offset_Ptr (To_Address (T)
 544                               - DT_Typeinfo_Ptr_Size
 545                               - DT_Offset_To_Top_Size);
 546    begin
 547       return Offset_To_Top_Ptr.all;
 548    end Offset_To_Top;
 549
 550    -----------------
 551    -- Parent_Size --
 552    -----------------
 553
 554    type Acc_Size
 555      is access function (A : System.Address) return Long_Long_Integer;
 556
 557    function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size);
 558    --  The profile of the implicitly defined _size primitive
 559
 560    function Parent_Size
 561      (Obj : System.Address;
 562       T   : Tag) return SSE.Storage_Count
 563    is
 564       Parent_Tag : constant Tag := TSD (T).Tags_Table (1);
 565       --  The tag of the parent type through the dispatch table
 566
 567       F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1));
 568       --  Access to the _size primitive of the parent. We assume that
 569       --  it is always in the first slot of the dispatch table
 570
 571    begin
 572       --  Here we compute the size of the _parent field of the object
 573
 574       return SSE.Storage_Count (F.all (Obj));
 575    end Parent_Size;
 576
 577    ----------------
 578    -- Parent_Tag --
 579    ----------------
 580
 581    function Parent_Tag (T : Tag) return Tag is
 582    begin
 583       if T = No_Tag then
 584          raise Tag_Error;
 585       end if;
 586
 587       --  The Parent_Tag of a root-level tagged type is defined to be No_Tag.
 588       --  The first entry in the Ancestors_Tags array will be null for such
 589       --  a type, but it's better to be explicit about returning No_Tag in
 590       --  this case.
 591
 592       if TSD (T).Idepth = 0 then
 593          return No_Tag;
 594       else
 595          return TSD (T).Tags_Table (1);
 596       end if;
 597    end Parent_Tag;
 598
 599    ----------------------------
 600    -- Register_Interface_Tag --
 601    ----------------------------
 602
 603    procedure Register_Interface_Tag
 604     (T           : Tag;
 605      Interface_T : Tag)
 606    is
 607       New_T_TSD : constant Type_Specific_Data_Ptr := TSD (T);
 608       Index     : Natural;
 609    begin
 610       --  Check if the interface is already registered
 611
 612       if New_T_TSD.Num_Interfaces > 0 then
 613          declare
 614             Id       : Natural          := New_T_TSD.Idepth + 1;
 615             Last_Id  : constant Natural := New_T_TSD.Idepth
 616                                             + New_T_TSD.Num_Interfaces;
 617          begin
 618             loop
 619                if New_T_TSD.Tags_Table (Id) = Interface_T then
 620                   return;
 621                end if;
 622
 623                Id := Id + 1;
 624                exit when Id > Last_Id;
 625             end loop;
 626          end;
 627       end if;
 628
 629       New_T_TSD.Num_Interfaces := New_T_TSD.Num_Interfaces + 1;
 630       Index := New_T_TSD.Idepth + New_T_TSD.Num_Interfaces;
 631       New_T_TSD.Tags_Table (Index) := Interface_T;
 632    end Register_Interface_Tag;
 633
 634    ------------------
 635    -- Register_Tag --
 636    ------------------
 637
 638    procedure Register_Tag (T : Tag) is
 639    begin
 640       External_Tag_HTable.Set (T);
 641    end Register_Tag;
 642
 643    ----------------------
 644    -- Set_Access_Level --
 645    ----------------------
 646
 647    procedure Set_Access_Level (T : Tag; Value : Natural) is
 648    begin
 649       TSD (T).Access_Level := Value;
 650    end Set_Access_Level;
 651
 652    -----------------------
 653    -- Set_Expanded_Name --
 654    -----------------------
 655
 656    procedure Set_Expanded_Name (T : Tag; Value : System.Address) is
 657    begin
 658       TSD (T).Expanded_Name := To_Cstring_Ptr (Value);
 659    end Set_Expanded_Name;
 660
 661    ----------------------
 662    -- Set_External_Tag --
 663    ----------------------
 664
 665    procedure Set_External_Tag (T : Tag; Value : System.Address) is
 666    begin
 667       TSD (T).External_Tag := To_Cstring_Ptr (Value);
 668    end Set_External_Tag;
 669
 670    -----------------------
 671    -- Set_Offset_To_Top --
 672    -----------------------
 673
 674    procedure Set_Offset_To_Top
 675      (T     : Tag;
 676       Value : System.Storage_Elements.Storage_Offset)
 677    is
 678       Offset_To_Top_Ptr : constant Storage_Offset_Ptr :=
 679                             To_Storage_Offset_Ptr (To_Address (T)
 680                               - DT_Typeinfo_Ptr_Size
 681                               - DT_Offset_To_Top_Size);
 682    begin
 683       Offset_To_Top_Ptr.all := Value;
 684    end Set_Offset_To_Top;
 685
 686    -------------------------
 687    -- Set_Prim_Op_Address --
 688    -------------------------
 689
 690    procedure Set_Prim_Op_Address
 691      (T        : Tag;
 692       Position : Positive;
 693       Value    : System.Address) is
 694    begin
 695       T.Prims_Ptr (Position) := Value;
 696    end Set_Prim_Op_Address;
 697
 698    -------------------
 699    -- Set_RC_Offset --
 700    -------------------
 701
 702    procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is
 703    begin
 704       TSD (T).RC_Offset := Value;
 705    end Set_RC_Offset;
 706
 707    ---------------------------
 708    -- Set_Remotely_Callable --
 709    ---------------------------
 710
 711    procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is
 712    begin
 713       TSD (T).Remotely_Callable := Value;
 714    end Set_Remotely_Callable;
 715
 716    -------------
 717    -- Set_TSD --
 718    -------------
 719
 720    procedure Set_TSD (T : Tag; Value : System.Address) is
 721       TSD_Ptr : constant Addr_Ptr :=
 722                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 723    begin
 724       TSD_Ptr.all := Value;
 725    end Set_TSD;
 726
 727    ------------------
 728    -- Typeinfo_Ptr --
 729    ------------------
 730
 731    function Typeinfo_Ptr (T : Tag) return System.Address is
 732       TSD_Ptr : constant Addr_Ptr :=
 733                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 734    begin
 735       return TSD_Ptr.all;
 736    end Typeinfo_Ptr;
 737
 738    ---------
 739    -- TSD --
 740    ---------
 741
 742    function TSD (T : Tag) return Type_Specific_Data_Ptr is
 743       TSD_Ptr : constant Addr_Ptr :=
 744                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 745    begin
 746       return To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 747    end TSD;
 748
 749 end Ada.Tags;