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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Exceptions;
  35 with 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 --                                          | table of          |
  72 --                                          :   primitive op    :
  73 --                                          |     kinds         |
  74 --                                          +-------------------+
  75 --                                          | table of          |
  76 --                                          :   entry           :
  77 --                                          |     indices       |
  78 --                                          +-------------------+
  79
  80    subtype Cstring is String (Positive);
  81    type Cstring_Ptr is access all Cstring;
  82
  83    --  We suppress index checks because the declared size in the record below
  84    --  is a dummy size of one (see below).
  85
  86    type Tag_Table is array (Natural range <>) of Tag;
  87    pragma Suppress_Initialization (Tag_Table);
  88    pragma Suppress (Index_Check, On => Tag_Table);
  89
  90    type Prim_Op_Kind_Table is array (Natural range <>) of Prim_Op_Kind;
  91    pragma Suppress_Initialization (Prim_Op_Kind_Table);
  92    pragma Suppress (Index_Check, On => Prim_Op_Kind_Table);
  93
  94    type Entry_Index_Table is array (Natural range <>) of Positive;
  95    pragma Suppress_Initialization (Entry_Index_Table);
  96    pragma Suppress (Index_Check, On => Entry_Index_Table);
  97
  98    type Type_Specific_Data is record
  99       Idepth : Natural;
 100       --  Inheritance Depth Level: Used to implement the membership test
 101       --  associated with single inheritance of tagged types in constant-time.
 102       --  In addition it also indicates the size of the first table stored in
 103       --  the Tags_Table component (see comment below).
 104
 105       Access_Level : Natural;
 106       --  Accessibility level required to give support to Ada 2005 nested type
 107       --  extensions. This feature allows safe nested type extensions by
 108       --  shifting the accessibility checks to certain operations, rather than
 109       --  being enforced at the type declaration. In particular, by performing
 110       --  run-time accessibility checks on class-wide allocators, class-wide
 111       --  function return, and class-wide stream I/O, the danger of objects
 112       --  outliving their type declaration can be eliminated (Ada 2005: AI-344)
 113
 114       Expanded_Name : Cstring_Ptr;
 115       External_Tag  : Cstring_Ptr;
 116       HT_Link       : Tag;
 117       --  Components used to give support to the Ada.Tags subprograms described
 118       --  in ARM 3.9
 119
 120       Remotely_Callable : Boolean;
 121       --  Used to check ARM E.4 (18)
 122
 123       RC_Offset : SSE.Storage_Offset;
 124       --  Controller Offset: Used to give support to tagged controlled objects
 125       --  (see Get_Deep_Controller at s-finimp)
 126
 127       Num_Interfaces : Natural;
 128       --  Number of abstract interface types implemented by the tagged type.
 129       --  The value Idepth+Num_Interfaces indicates the end of the second table
 130       --  stored in the Tags_Table component. It is used to implement the
 131       --  membership test associated with interfaces (Ada 2005:AI-251)
 132
 133       Tags_Table : Tag_Table (0 .. 1);
 134       --  The size of the Tags_Table array actually depends on the tagged type
 135       --  to which it applies. The compiler ensures that has enough space to
 136       --  store all the entries of the two tables phisically stored there: the
 137       --  "table of ancestor tags" and the "table of interface tags". For this
 138       --  purpose we are using the same mechanism as for the Prims_Ptr array in
 139       --  the Dispatch_Table record. See comments below on Prims_Ptr for
 140       --  further details.
 141
 142       POK_Table       : Prim_Op_Kind_Table (1 .. 1);
 143       Ent_Index_Table : Entry_Index_Table  (1 .. 1);
 144       --  Two auxiliary tables used for dispatching in asynchronous,
 145       --  conditional and timed selects. Their size depends on the number
 146       --  of primitive operations. Indexing in these two tables is performed
 147       --  by subtracting the number of predefined primitive operations from
 148       --  the given index value. POK_Table contains the callable entity kinds
 149       --  of all non-predefined primitive operations. Ent_Index_Table contains
 150       --  the entry index of primitive entry wrappers.
 151    end record;
 152
 153    type Dispatch_Table is record
 154       --  Offset_To_Top : Natural;
 155       --  Typeinfo_Ptr  : System.Address;
 156
 157       --  According to the C++ ABI the components Offset_To_Top and
 158       --  Typeinfo_Ptr are stored just "before" the dispatch table (that is,
 159       --  the Prims_Ptr table), and they are referenced with negative offsets
 160       --  referring to the base of the dispatch table. The _Tag (or the
 161       --  VTable_Ptr in C++ terminology) must point to the base of the virtual
 162       --  table, just after these components, to point to the Prims_Ptr table.
 163       --  For this purpose the expander generates a Prims_Ptr table that has
 164       --  enough space for these additional components, and generates code that
 165       --  displaces the _Tag to point after these components.
 166
 167       Prims_Ptr : Address_Array (1 .. 1);
 168       --  The size of the Prims_Ptr array actually depends on the tagged type
 169       --  to which it applies. For each tagged type, the expander computes the
 170       --  actual array size, allocates the Dispatch_Table record accordingly,
 171       --  and generates code that displaces the base of the record after the
 172       --  Typeinfo_Ptr component. For this reason the first two components have
 173       --  been commented in the previous declaration. The access to these
 174       --  components is done by means of local functions.
 175       --
 176       --  To avoid the use of discriminants to define the actual size of the
 177       --  dispatch table, we used to declare the tag as a pointer to a record
 178       --  that contains an arbitrary array of addresses, using Positive as its
 179       --  index. This ensures that there are never range checks when accessing
 180       --  the dispatch table, but it prevents GDB from displaying tagged types
 181       --  properly. A better approach is to declare this record type as holding
 182       --  small number of addresses, and to explicitly suppress checks on it.
 183       --
 184       --  Note that in both cases, this type is never allocated, and serves
 185       --  only to declare the corresponding access type.
 186    end record;
 187
 188    ---------------------------------------------
 189    -- Unchecked Conversions for String Fields --
 190    ---------------------------------------------
 191
 192    function To_Address is
 193      new Unchecked_Conversion (Cstring_Ptr, System.Address);
 194
 195    function To_Cstring_Ptr is
 196      new Unchecked_Conversion (System.Address, Cstring_Ptr);
 197
 198    ------------------------------------------------
 199    -- Unchecked Conversions for other components --
 200    ------------------------------------------------
 201
 202    type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset;
 203
 204    function To_Storage_Offset_Ptr is
 205      new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
 206
 207    -----------------------
 208    -- Local Subprograms --
 209    -----------------------
 210
 211    function Length (Str : Cstring_Ptr) return Natural;
 212    --  Length of string represented by the given pointer (treating the string
 213    --  as a C-style string, which is Nul terminated).
 214
 215    function Offset_To_Top
 216      (T : Tag) return System.Storage_Elements.Storage_Offset;
 217    --  Returns the current value of the offset_to_top component available in
 218    --  the prologue of the dispatch table.
 219
 220    function Typeinfo_Ptr (T : Tag) return System.Address;
 221    --  Returns the current value of the typeinfo_ptr component available in
 222    --  the prologue of the dispatch table.
 223
 224    pragma Unreferenced (Typeinfo_Ptr);
 225    --  These functions will be used for full compatibility with the C++ ABI
 226
 227    -------------------------
 228    -- External_Tag_HTable --
 229    -------------------------
 230
 231    type HTable_Headers is range 1 .. 64;
 232
 233    --  The following internal package defines the routines used for the
 234    --  instantiation of a new System.HTable.Static_HTable (see below). See
 235    --  spec in g-htable.ads for details of usage.
 236
 237    package HTable_Subprograms is
 238       procedure Set_HT_Link (T : Tag; Next : Tag);
 239       function  Get_HT_Link (T : Tag) return Tag;
 240       function Hash (F : System.Address) return HTable_Headers;
 241       function Equal (A, B : System.Address) return Boolean;
 242    end HTable_Subprograms;
 243
 244    package External_Tag_HTable is new System.HTable.Static_HTable (
 245      Header_Num => HTable_Headers,
 246      Element    => Dispatch_Table,
 247      Elmt_Ptr   => Tag,
 248      Null_Ptr   => null,
 249      Set_Next   => HTable_Subprograms.Set_HT_Link,
 250      Next       => HTable_Subprograms.Get_HT_Link,
 251      Key        => System.Address,
 252      Get_Key    => Get_External_Tag,
 253      Hash       => HTable_Subprograms.Hash,
 254      Equal      => HTable_Subprograms.Equal);
 255
 256    ------------------------
 257    -- HTable_Subprograms --
 258    ------------------------
 259
 260    --  Bodies of routines for hash table instantiation
 261
 262    package body HTable_Subprograms is
 263
 264    -----------
 265    -- Equal --
 266    -----------
 267
 268       function Equal (A, B : System.Address) return Boolean is
 269          Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
 270          Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
 271          J    : Integer := 1;
 272       begin
 273          loop
 274             if Str1 (J) /= Str2 (J) then
 275                return False;
 276             elsif Str1 (J) = ASCII.NUL then
 277                return True;
 278             else
 279                J := J + 1;
 280             end if;
 281          end loop;
 282       end Equal;
 283
 284       -----------------
 285       -- Get_HT_Link --
 286       -----------------
 287
 288       function Get_HT_Link (T : Tag) return Tag is
 289       begin
 290          return TSD (T).HT_Link;
 291       end Get_HT_Link;
 292
 293       ----------
 294       -- Hash --
 295       ----------
 296
 297       function Hash (F : System.Address) return HTable_Headers is
 298          function H is new System.HTable.Hash (HTable_Headers);
 299          Str : constant Cstring_Ptr    := To_Cstring_Ptr (F);
 300          Res : constant HTable_Headers := H (Str (1 .. Length (Str)));
 301       begin
 302          return Res;
 303       end Hash;
 304
 305       -----------------
 306       -- Set_HT_Link --
 307       -----------------
 308
 309       procedure Set_HT_Link (T : Tag; Next : Tag) is
 310       begin
 311          TSD (T).HT_Link := Next;
 312       end Set_HT_Link;
 313
 314    end HTable_Subprograms;
 315
 316    -------------------
 317    -- CW_Membership --
 318    -------------------
 319
 320    --  Canonical implementation of Classwide Membership corresponding to:
 321
 322    --     Obj in Typ'Class
 323
 324    --  Each dispatch table contains a reference to a table of ancestors (stored
 325    --  in the first part of the Tags_Table) and a count of the level of
 326    --  inheritance "Idepth".
 327
 328    --  Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
 329    --  contained in the dispatch table referenced by Obj'Tag . Knowing the
 330    --  level of inheritance of both types, this can be computed in constant
 331    --  time by the formula:
 332
 333    --   Obj'tag.TSD.Ancestor_Tags (Obj'tag.TSD.Idepth - Typ'tag.TSD.Idepth)
 334    --     = Typ'tag
 335
 336    function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
 337       Pos : constant Integer := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
 338    begin
 339       return Pos >= 0 and then TSD (Obj_Tag).Tags_Table (Pos) = Typ_Tag;
 340    end CW_Membership;
 341
 342    -------------------
 343    -- IW_Membership --
 344    -------------------
 345
 346    --  Canonical implementation of Classwide Membership corresponding to:
 347
 348    --     Obj in Iface'Class
 349
 350    --  Each dispatch table contains a table with the tags of all the
 351    --  implemented interfaces.
 352
 353    --  Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
 354    --  that are contained in the dispatch table referenced by Obj'Tag.
 355
 356    function IW_Membership
 357      (This : System.Address;
 358       T    : Tag) return Boolean
 359    is
 360       Curr_DT  : constant Tag := To_Tag_Ptr (This).all;
 361       Obj_Base : constant System.Address := This - Offset_To_Top (Curr_DT);
 362       Obj_DT   : constant Tag := To_Tag_Ptr (Obj_Base).all;
 363
 364       Obj_TSD : constant Type_Specific_Data_Ptr := TSD (Obj_DT);
 365       Last_Id : constant Natural := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces;
 366       Id      : Natural;
 367
 368    begin
 369       if Obj_TSD.Num_Interfaces > 0 then
 370
 371          --  Traverse the ancestor tags table plus the interface tags table.
 372          --  The former part is required to give support to:
 373          --     Iface_CW in Typ'Class
 374
 375          Id := 0;
 376          loop
 377             if Obj_TSD.Tags_Table (Id) = T then
 378                return True;
 379             end if;
 380
 381             Id := Id + 1;
 382             exit when Id > Last_Id;
 383          end loop;
 384       end if;
 385
 386       return False;
 387    end IW_Membership;
 388
 389    --------------------
 390    -- Descendant_Tag --
 391    --------------------
 392
 393    function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
 394       Int_Tag : constant Tag := Internal_Tag (External);
 395
 396    begin
 397       if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
 398          raise Tag_Error;
 399       end if;
 400
 401       return Int_Tag;
 402    end Descendant_Tag;
 403
 404    -------------------
 405    -- Expanded_Name --
 406    -------------------
 407
 408    function Expanded_Name (T : Tag) return String is
 409       Result : Cstring_Ptr;
 410
 411    begin
 412       if T = No_Tag then
 413          raise Tag_Error;
 414       end if;
 415
 416       Result := TSD (T).Expanded_Name;
 417       return Result (1 .. Length (Result));
 418    end Expanded_Name;
 419
 420    ------------------
 421    -- External_Tag --
 422    ------------------
 423
 424    function External_Tag (T : Tag) return String is
 425       Result : Cstring_Ptr;
 426    begin
 427       if T = No_Tag then
 428          raise Tag_Error;
 429       end if;
 430
 431       Result := TSD (T).External_Tag;
 432
 433       return Result (1 .. Length (Result));
 434    end External_Tag;
 435
 436    ----------------------
 437    -- Get_Access_Level --
 438    ----------------------
 439
 440    function Get_Access_Level (T : Tag) return Natural is
 441    begin
 442       return TSD (T).Access_Level;
 443    end Get_Access_Level;
 444
 445    ---------------------
 446    -- Get_Entry_Index --
 447    ---------------------
 448
 449    function Get_Entry_Index
 450      (T        : Tag;
 451       Position : Positive) return Positive is
 452    begin
 453       return TSD (T).Ent_Index_Table (Position - Default_Prim_Op_Count);
 454    end Get_Entry_Index;
 455
 456    ----------------------
 457    -- Get_External_Tag --
 458    ----------------------
 459
 460    function Get_External_Tag (T : Tag) return System.Address is
 461    begin
 462       return To_Address (TSD (T).External_Tag);
 463    end Get_External_Tag;
 464
 465    -------------------------
 466    -- Get_Prim_Op_Address --
 467    -------------------------
 468
 469    function Get_Prim_Op_Address
 470      (T        : Tag;
 471       Position : Positive) return System.Address is
 472    begin
 473       return T.Prims_Ptr (Position);
 474    end Get_Prim_Op_Address;
 475
 476    ----------------------
 477    -- Get_Prim_Op_Kind --
 478    ----------------------
 479
 480    function Get_Prim_Op_Kind
 481      (T        : Tag;
 482       Position : Positive) return Prim_Op_Kind is
 483    begin
 484       return TSD (T).POK_Table (Position - Default_Prim_Op_Count);
 485    end Get_Prim_Op_Kind;
 486
 487    -------------------
 488    -- Get_RC_Offset --
 489    -------------------
 490
 491    function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is
 492    begin
 493       return TSD (T).RC_Offset;
 494    end Get_RC_Offset;
 495
 496    ---------------------------
 497    -- Get_Remotely_Callable --
 498    ---------------------------
 499
 500    function Get_Remotely_Callable (T : Tag) return Boolean is
 501    begin
 502       return TSD (T).Remotely_Callable;
 503    end Get_Remotely_Callable;
 504
 505    ----------------
 506    -- Inherit_DT --
 507    ----------------
 508
 509    procedure Inherit_DT
 510     (Old_T       : Tag;
 511      New_T       : Tag;
 512      Entry_Count : Natural)
 513    is
 514    begin
 515       if Old_T /= null then
 516          New_T.Prims_Ptr (1 .. Entry_Count) :=
 517            Old_T.Prims_Ptr (1 .. Entry_Count);
 518       end if;
 519    end Inherit_DT;
 520
 521    -----------------
 522    -- Inherit_TSD --
 523    -----------------
 524
 525    procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag) is
 526       New_TSD_Ptr : constant Type_Specific_Data_Ptr := TSD (New_Tag);
 527       Old_TSD_Ptr : Type_Specific_Data_Ptr;
 528
 529    begin
 530       if Old_Tag /= null then
 531          Old_TSD_Ptr := TSD (Old_Tag);
 532          New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1;
 533          New_TSD_Ptr.Num_Interfaces := Old_TSD_Ptr.Num_Interfaces;
 534
 535          --  Copy the "table of ancestor tags" plus the "table of interfaces"
 536          --  of the parent
 537
 538          New_TSD_Ptr.Tags_Table
 539            (1 .. New_TSD_Ptr.Idepth + New_TSD_Ptr.Num_Interfaces) :=
 540              Old_TSD_Ptr.Tags_Table
 541                (0 .. Old_TSD_Ptr.Idepth + Old_TSD_Ptr.Num_Interfaces);
 542       else
 543          New_TSD_Ptr.Idepth         := 0;
 544          New_TSD_Ptr.Num_Interfaces := 0;
 545       end if;
 546
 547       New_TSD_Ptr.Tags_Table (0) := New_Tag;
 548    end Inherit_TSD;
 549
 550    ------------------
 551    -- Internal_Tag --
 552    ------------------
 553
 554    function Internal_Tag (External : String) return Tag is
 555       Ext_Copy : aliased String (External'First .. External'Last + 1);
 556       Res      : Tag;
 557
 558    begin
 559       --  Make a copy of the string representing the external tag with
 560       --  a null at the end
 561
 562       Ext_Copy (External'Range) := External;
 563       Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
 564       Res := External_Tag_HTable.Get (Ext_Copy'Address);
 565
 566       if Res = null then
 567          declare
 568             Msg1 : constant String := "unknown tagged type: ";
 569             Msg2 : String (1 .. Msg1'Length + External'Length);
 570          begin
 571             Msg2 (1 .. Msg1'Length) := Msg1;
 572             Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
 573               External;
 574             Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2);
 575          end;
 576       end if;
 577
 578       return Res;
 579    end Internal_Tag;
 580
 581    ---------------------------------
 582    -- Is_Descendant_At_Same_Level --
 583    ---------------------------------
 584
 585    function Is_Descendant_At_Same_Level
 586      (Descendant : Tag;
 587       Ancestor   : Tag) return Boolean
 588    is
 589    begin
 590       return CW_Membership (Descendant, Ancestor)
 591         and then TSD (Descendant).Access_Level = TSD (Ancestor).Access_Level;
 592    end Is_Descendant_At_Same_Level;
 593
 594    ------------
 595    -- Length --
 596    ------------
 597
 598    function Length (Str : Cstring_Ptr) return Natural is
 599       Len : Integer := 1;
 600
 601    begin
 602       while Str (Len) /= ASCII.Nul loop
 603          Len := Len + 1;
 604       end loop;
 605
 606       return Len - 1;
 607    end Length;
 608
 609    -------------------
 610    -- Offset_To_Top --
 611    -------------------
 612
 613    function Offset_To_Top
 614      (T : Tag) return System.Storage_Elements.Storage_Offset
 615    is
 616       Offset_To_Top_Ptr : constant Storage_Offset_Ptr :=
 617                             To_Storage_Offset_Ptr (To_Address (T)
 618                               - DT_Typeinfo_Ptr_Size
 619                               - DT_Offset_To_Top_Size);
 620    begin
 621       return Offset_To_Top_Ptr.all;
 622    end Offset_To_Top;
 623
 624    -----------------
 625    -- Parent_Size --
 626    -----------------
 627
 628    type Acc_Size
 629      is access function (A : System.Address) return Long_Long_Integer;
 630
 631    function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size);
 632    --  The profile of the implicitly defined _size primitive
 633
 634    function Parent_Size
 635      (Obj : System.Address;
 636       T   : Tag) return SSE.Storage_Count
 637    is
 638       Parent_Tag : constant Tag := TSD (T).Tags_Table (1);
 639       --  The tag of the parent type through the dispatch table
 640
 641       F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1));
 642       --  Access to the _size primitive of the parent. We assume that it is
 643       --  always in the first slot of the dispatch table
 644
 645    begin
 646       --  Here we compute the size of the _parent field of the object
 647
 648       return SSE.Storage_Count (F.all (Obj));
 649    end Parent_Size;
 650
 651    ----------------
 652    -- Parent_Tag --
 653    ----------------
 654
 655    function Parent_Tag (T : Tag) return Tag is
 656    begin
 657       if T = No_Tag then
 658          raise Tag_Error;
 659       end if;
 660
 661       --  The Parent_Tag of a root-level tagged type is defined to be No_Tag.
 662       --  The first entry in the Ancestors_Tags array will be null for such
 663       --  a type, but it's better to be explicit about returning No_Tag in
 664       --  this case.
 665
 666       if TSD (T).Idepth = 0 then
 667          return No_Tag;
 668       else
 669          return TSD (T).Tags_Table (1);
 670       end if;
 671    end Parent_Tag;
 672
 673    ----------------------------
 674    -- Register_Interface_Tag --
 675    ----------------------------
 676
 677    procedure Register_Interface_Tag
 678     (T           : Tag;
 679      Interface_T : Tag)
 680    is
 681       New_T_TSD : constant Type_Specific_Data_Ptr := TSD (T);
 682       Index     : Natural;
 683    begin
 684       --  Check if the interface is already registered
 685
 686       if New_T_TSD.Num_Interfaces > 0 then
 687          declare
 688             Id       : Natural          := New_T_TSD.Idepth + 1;
 689             Last_Id  : constant Natural := New_T_TSD.Idepth
 690                                             + New_T_TSD.Num_Interfaces;
 691          begin
 692             loop
 693                if New_T_TSD.Tags_Table (Id) = Interface_T then
 694                   return;
 695                end if;
 696
 697                Id := Id + 1;
 698                exit when Id > Last_Id;
 699             end loop;
 700          end;
 701       end if;
 702
 703       New_T_TSD.Num_Interfaces := New_T_TSD.Num_Interfaces + 1;
 704       Index := New_T_TSD.Idepth + New_T_TSD.Num_Interfaces;
 705       New_T_TSD.Tags_Table (Index) := Interface_T;
 706    end Register_Interface_Tag;
 707
 708    ------------------
 709    -- Register_Tag --
 710    ------------------
 711
 712    procedure Register_Tag (T : Tag) is
 713    begin
 714       External_Tag_HTable.Set (T);
 715    end Register_Tag;
 716
 717    ----------------------
 718    -- Set_Access_Level --
 719    ----------------------
 720
 721    procedure Set_Access_Level (T : Tag; Value : Natural) is
 722    begin
 723       TSD (T).Access_Level := Value;
 724    end Set_Access_Level;
 725
 726    ---------------------
 727    -- Set_Entry_Index --
 728    ---------------------
 729
 730    procedure Set_Entry_Index
 731      (T        : Tag;
 732       Position : Positive;
 733       Value    : Positive) is
 734    begin
 735       TSD (T).Ent_Index_Table (Position - Default_Prim_Op_Count) := Value;
 736    end Set_Entry_Index;
 737
 738    -----------------------
 739    -- Set_Expanded_Name --
 740    -----------------------
 741
 742    procedure Set_Expanded_Name (T : Tag; Value : System.Address) is
 743    begin
 744       TSD (T).Expanded_Name := To_Cstring_Ptr (Value);
 745    end Set_Expanded_Name;
 746
 747    ----------------------
 748    -- Set_External_Tag --
 749    ----------------------
 750
 751    procedure Set_External_Tag (T : Tag; Value : System.Address) is
 752    begin
 753       TSD (T).External_Tag := To_Cstring_Ptr (Value);
 754    end Set_External_Tag;
 755
 756    -----------------------
 757    -- Set_Offset_To_Top --
 758    -----------------------
 759
 760    procedure Set_Offset_To_Top
 761      (T     : Tag;
 762       Value : System.Storage_Elements.Storage_Offset)
 763    is
 764       Offset_To_Top_Ptr : constant Storage_Offset_Ptr :=
 765                             To_Storage_Offset_Ptr (To_Address (T)
 766                               - DT_Typeinfo_Ptr_Size
 767                               - DT_Offset_To_Top_Size);
 768    begin
 769       Offset_To_Top_Ptr.all := Value;
 770    end Set_Offset_To_Top;
 771
 772    -------------------------
 773    -- Set_Prim_Op_Address --
 774    -------------------------
 775
 776    procedure Set_Prim_Op_Address
 777      (T        : Tag;
 778       Position : Positive;
 779       Value    : System.Address) is
 780    begin
 781       T.Prims_Ptr (Position) := Value;
 782    end Set_Prim_Op_Address;
 783
 784    ----------------------
 785    -- Set_Prim_Op_Kind --
 786    ----------------------
 787
 788    procedure Set_Prim_Op_Kind
 789      (T        : Tag;
 790       Position : Positive;
 791       Value    : Prim_Op_Kind) is
 792    begin
 793       TSD (T).POK_Table (Position - Default_Prim_Op_Count) := Value;
 794    end Set_Prim_Op_Kind;
 795
 796    -------------------
 797    -- Set_RC_Offset --
 798    -------------------
 799
 800    procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is
 801    begin
 802       TSD (T).RC_Offset := Value;
 803    end Set_RC_Offset;
 804
 805    ---------------------------
 806    -- Set_Remotely_Callable --
 807    ---------------------------
 808
 809    procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is
 810    begin
 811       TSD (T).Remotely_Callable := Value;
 812    end Set_Remotely_Callable;
 813
 814    -------------
 815    -- Set_TSD --
 816    -------------
 817
 818    procedure Set_TSD (T : Tag; Value : System.Address) is
 819       TSD_Ptr : constant Addr_Ptr :=
 820                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 821    begin
 822       TSD_Ptr.all := Value;
 823    end Set_TSD;
 824
 825    ------------------
 826    -- Typeinfo_Ptr --
 827    ------------------
 828
 829    function Typeinfo_Ptr (T : Tag) return System.Address is
 830       TSD_Ptr : constant Addr_Ptr :=
 831                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 832    begin
 833       return TSD_Ptr.all;
 834    end Typeinfo_Ptr;
 835
 836    ---------
 837    -- TSD --
 838    ---------
 839
 840    function TSD (T : Tag) return Type_Specific_Data_Ptr is
 841       TSD_Ptr : constant Addr_Ptr :=
 842                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 843    begin
 844       return To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 845    end TSD;
 846
 847 end Ada.Tags;