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 Primary Dispatch Table
  43
  44 --           +----------------------+
  45 --           |       Signature      |
  46 --           +----------------------+
  47 --           |      Tagged_Kind     |
  48 --           +----------------------+
  49 --           |     Offset_To_Top    |
  50 --           +----------------------+
  51 --           | Typeinfo_Ptr/TSD_Ptr ---> Type Specific Data
  52 --  Tag ---> +----------------------+   +-------------------+
  53 --           |       table of       |   | inheritance depth |
  54 --           :    primitive ops     :   +-------------------+
  55 --           |       pointers       |   |   access level    |
  56 --           +----------------------+   +-------------------+
  57 --                                      |   expanded name   |
  58 --                                      +-------------------+
  59 --                                      |   external tag    |
  60 --                                      +-------------------+
  61 --                                      |   hash table link |
  62 --                                      +-------------------+
  63 --                                      | remotely callable |
  64 --                                      +-------------------+
  65 --                                      | rec ctrler offset |
  66 --                                      +-------------------+
  67 --                                      |   num prim ops    |
  68 --                                      +-------------------+
  69 --                                      |  num interfaces   |
  70 --                                      +-------------------+
  71 --                                      |  Ifaces_Table_Ptr --> Interface Data
  72 --                                      +-------------------+   +------------+
  73 --            Select Specific Data  <----     SSD_Ptr       |   |  table     |
  74 --           +--------------------+     +-------------------+   :    of      :
  75 --           | table of primitive |     | table of          |   | interfaces |
  76 --           :    operation       :     :    ancestor       :   +------------+
  77 --           |       kinds        |     |       tags        |
  78 --           +--------------------+     +-------------------+
  79 --           | table of           |
  80 --           :    entry           :
  81 --           |       indices      |
  82 --           +--------------------+
  83
  84 --  Structure of the GNAT Secondary Dispatch Table
  85
  86 --           +-----------------------+
  87 --           |       Signature       |
  88 --           +-----------------------+
  89 --           |      Tagged_Kind      |
  90 --           +-----------------------+
  91 --           |     Offset_To_Top     |
  92 --           +-----------------------+
  93 --           |        OSD_Ptr        |---> Object Specific Data
  94 --  Tag ---> +-----------------------+      +---------------+
  95 --           |        table of       |      | num prim ops  |
  96 --           :      primitive op     :      +---------------+
  97 --           |     thunk pointers    |      | table of      |
  98 --           +-----------------------+      +   primitive   |
  99 --                                          |    op offsets |
 100 --                                          +---------------+
 101
 102    ----------------------------------
 103    -- GNAT Dispatch Table Prologue --
 104    ----------------------------------
 105
 106    --  GNAT's Dispatch Table prologue contains several fields which are hidden
 107    --  in order to preserve compatibility with C++. These fields are accessed
 108    --  by address calculations performed in the following manner:
 109
 110    --     Field : Field_Type :=
 111    --               (To_Address (Tag) - Sum_Of_Preceding_Field_Sizes).all;
 112
 113    --  The bracketed subtraction shifts the pointer (Tag) from the table of
 114    --  primitive operations (or thunks) to the field in question. Since the
 115    --  result of the subtraction is an address, dereferencing it will obtain
 116    --  the actual value of the field.
 117
 118    --  Guidelines for addition of new hidden fields
 119
 120    --     Define a Field_Type and Field_Type_Ptr (access to Field_Type) in
 121    --     A-Tags.ads for the newly introduced field.
 122
 123    --     Defined the size of the new field as a constant Field_Name_Size
 124
 125    --     Introduce an Unchecked_Conversion from System.Address to
 126    --     Field_Type_Ptr in A-Tags.ads.
 127
 128    --     Define the specifications of Get_<Field_Name> and Set_<Field_Name>
 129    --     in A-Tags.ads.
 130
 131    --     Update the GNAT Dispatch Table structure in A-Tags.adb
 132
 133    --     Provide bodies to the Get_<Field_Name> and Set_<Field_Name> routines.
 134    --     The profile of a Get_<Field_Name> routine should resemble:
 135
 136    --        function Get_<Field_Name> (T : Tag; ...) return Field_Type is
 137    --           Field : constant System.Address :=
 138    --                     To_Address (T) - <Sum_Of_Previous_Field_Sizes>;
 139    --        begin
 140    --           pragma Assert (Check_Signature (T, <Applicable_DT>));
 141    --           <Additional_Assertions>
 142
 143    --           return To_Field_Type_Ptr (Field).all;
 144    --        end Get_<Field_Name>;
 145
 146    --     The profile of a Set_<Field_Name> routine should resemble:
 147
 148    --        procedure Set_<Field_Name> (T : Tag; ..., Value : Field_Type) is
 149    --           Field : constant System.Address :=
 150    --                     To_Address (T) - <Sum_Of_Previous_Field_Sizes>;
 151    --           begin
 152    --           pragma Assert (Check_Signature (T, <Applicable_DT>));
 153    --           <Additional_Assertions>
 154
 155    --           To_Field_Type_Ptr (Field).all := Value;
 156    --        end Set_<Field_Name>;
 157
 158    --  NOTE: For each field in the prologue which precedes the newly added
 159    --  one, find and update its respective Sum_Of_Previous_Field_Sizes by
 160    --  subtractind Field_Name_Size from it. Falure to do so will clobber the
 161    --  previous prologue field.
 162
 163    K_Typeinfo      : constant SSE.Storage_Count := DT_Typeinfo_Ptr_Size;
 164
 165    K_Offset_To_Top : constant SSE.Storage_Count :=
 166                        K_Typeinfo + DT_Offset_To_Top_Size;
 167
 168    K_Tagged_Kind   : constant SSE.Storage_Count :=
 169                        K_Offset_To_Top + DT_Tagged_Kind_Size;
 170
 171    K_Signature     : constant SSE.Storage_Count :=
 172                        K_Tagged_Kind + DT_Signature_Size;
 173
 174    subtype Cstring is String (Positive);
 175    type Cstring_Ptr is access all Cstring;
 176
 177    --  We suppress index checks because the declared size in the record below
 178    --  is a dummy size of one (see below).
 179
 180    type Tag_Table is array (Natural range <>) of Tag;
 181    pragma Suppress_Initialization (Tag_Table);
 182    pragma Suppress (Index_Check, On => Tag_Table);
 183
 184    --  Declarations for the table of interfaces
 185
 186    type Interface_Data_Element is record
 187       Iface_Tag : Tag;
 188       Offset    : System.Storage_Elements.Storage_Offset;
 189    end record;
 190
 191    type Interfaces_Array is
 192      array (Natural range <>) of Interface_Data_Element;
 193
 194    type Interface_Data (Nb_Ifaces : Positive) is record
 195       Table : Interfaces_Array (1 .. Nb_Ifaces);
 196    end record;
 197
 198    --  Object specific data types
 199
 200    type Object_Specific_Data_Array is array (Positive range <>) of Positive;
 201
 202    type Object_Specific_Data (Nb_Prim : Positive) is record
 203       Num_Prim_Ops : Natural;
 204       --  Number of primitive operations of the dispatch table. This field is
 205       --  used by the run-time check routines that are activated when the
 206       --  run-time is compiled with assertions enabled.
 207
 208       OSD_Table : Object_Specific_Data_Array (1 .. Nb_Prim);
 209       --  Table used in secondary DT to reference their counterpart in the
 210       --  select specific data (in the TSD of the primary DT). This construct
 211       --  is used in the handling of dispatching triggers in select statements.
 212       --  Nb_Prim is the number of non-predefined primitive operations.
 213    end record;
 214
 215    --  Select specific data types
 216
 217    type Select_Specific_Data_Element is record
 218       Index : Positive;
 219       Kind  : Prim_Op_Kind;
 220    end record;
 221
 222    type Select_Specific_Data_Array is
 223      array (Positive range <>) of Select_Specific_Data_Element;
 224
 225    type Select_Specific_Data (Nb_Prim : Positive) is record
 226       SSD_Table : Select_Specific_Data_Array (1 .. Nb_Prim);
 227       --  NOTE: Nb_Prim is the number of non-predefined primitive operations
 228    end record;
 229
 230    --  Type specific data types
 231
 232    type Type_Specific_Data is record
 233       Idepth : Natural;
 234       --  Inheritance Depth Level: Used to implement the membership test
 235       --  associated with single inheritance of tagged types in constant-time.
 236       --  In addition it also indicates the size of the first table stored in
 237       --  the Tags_Table component (see comment below).
 238
 239       Access_Level : Natural;
 240       --  Accessibility level required to give support to Ada 2005 nested type
 241       --  extensions. This feature allows safe nested type extensions by
 242       --  shifting the accessibility checks to certain operations, rather than
 243       --  being enforced at the type declaration. In particular, by performing
 244       --  run-time accessibility checks on class-wide allocators, class-wide
 245       --  function return, and class-wide stream I/O, the danger of objects
 246       --  outliving their type declaration can be eliminated (Ada 2005: AI-344)
 247
 248       Expanded_Name : Cstring_Ptr;
 249       External_Tag  : Cstring_Ptr;
 250       HT_Link       : Tag;
 251       --  Components used to give support to the Ada.Tags subprograms described
 252       --  in ARM 3.9
 253
 254       Remotely_Callable : Boolean;
 255       --  Used to check ARM E.4 (18)
 256
 257       RC_Offset : SSE.Storage_Offset;
 258       --  Controller Offset: Used to give support to tagged controlled objects
 259       --  (see Get_Deep_Controller at s-finimp)
 260
 261       Ifaces_Table_Ptr : System.Address;
 262       --  Pointer to the table of interface tags. It is used to implement the
 263       --  membership test associated with interfaces and also for backward
 264       --  abstract interface type conversions (Ada 2005:AI-251)
 265
 266       Num_Prim_Ops : Natural;
 267       --  Number of primitive operations of the dispatch table. This field is
 268       --  used for additional run-time checks when the run-time is compiled
 269       --  with assertions enabled.
 270
 271       SSD_Ptr : System.Address;
 272       --  Pointer to a table of records used in dispatching selects. This
 273       --  field has a meaningful value for all tagged types that implement
 274       --  a limited, protected, synchronized or task interfaces and have
 275       --  non-predefined primitive operations.
 276
 277       Tags_Table : Tag_Table (0 .. 1);
 278       --  The size of the Tags_Table array actually depends on the tagged type
 279       --  to which it applies. The compiler ensures that has enough space to
 280       --  store all the entries of the two tables phisically stored there: the
 281       --  "table of ancestor tags" and the "table of interface tags". For this
 282       --  purpose we are using the same mechanism as for the Prims_Ptr array in
 283       --  the Dispatch_Table record. See comments below on Prims_Ptr for
 284       --  further details.
 285    end record;
 286
 287    type Dispatch_Table is record
 288
 289       --  According to the C++ ABI the components Offset_To_Top and
 290       --  Typeinfo_Ptr are stored just "before" the dispatch table (that is,
 291       --  the Prims_Ptr table), and they are referenced with negative offsets
 292       --  referring to the base of the dispatch table. The _Tag (or the
 293       --  VTable_Ptr in C++ terminology) must point to the base of the virtual
 294       --  table, just after these components, to point to the Prims_Ptr table.
 295       --  For this purpose the expander generates a Prims_Ptr table that has
 296       --  enough space for these additional components, and generates code that
 297       --  displaces the _Tag to point after these components.
 298
 299       --  Signature     : Signature_Kind;
 300       --  Tagged_Kind   : Tagged_Kind;
 301       --  Offset_To_Top : Natural;
 302       --  Typeinfo_Ptr  : System.Address;
 303
 304       Prims_Ptr : Address_Array (1 .. 1);
 305       --  The size of the Prims_Ptr array actually depends on the tagged type
 306       --  to which it applies. For each tagged type, the expander computes the
 307       --  actual array size, allocates the Dispatch_Table record accordingly,
 308       --  and generates code that displaces the base of the record after the
 309       --  Typeinfo_Ptr component. For this reason the first two components have
 310       --  been commented in the previous declaration. The access to these
 311       --  components is done by means of local functions.
 312       --
 313       --  To avoid the use of discriminants to define the actual size of the
 314       --  dispatch table, we used to declare the tag as a pointer to a record
 315       --  that contains an arbitrary array of addresses, using Positive as its
 316       --  index. This ensures that there are never range checks when accessing
 317       --  the dispatch table, but it prevents GDB from displaying tagged types
 318       --  properly. A better approach is to declare this record type as holding
 319       --  small number of addresses, and to explicitly suppress checks on it.
 320       --
 321       --  Note that in both cases, this type is never allocated, and serves
 322       --  only to declare the corresponding access type.
 323    end record;
 324
 325    --  Run-time check types and subprograms: These subprograms are used only
 326    --  when the run-time is compiled with assertions enabled.
 327
 328    type Signature_Type is
 329       (Must_Be_Primary_DT,
 330        Must_Be_Secondary_DT,
 331        Must_Be_Primary_Or_Secondary_DT,
 332        Must_Be_Interface,
 333        Must_Be_Primary_Or_Interface);
 334    --  Type of signature accepted by primitives in this package that are called
 335    --  during the elaboration of tagged types. This type is used by the routine
 336    --  Check_Signature that is called only when the run-time is compiled with
 337    --  assertions enabled.
 338
 339    ---------------------------------------------
 340    -- Unchecked Conversions for String Fields --
 341    ---------------------------------------------
 342
 343    function To_Address is
 344      new Unchecked_Conversion (Cstring_Ptr, System.Address);
 345
 346    function To_Cstring_Ptr is
 347      new Unchecked_Conversion (System.Address, Cstring_Ptr);
 348
 349    ------------------------------------------------
 350    -- Unchecked Conversions for other components --
 351    ------------------------------------------------
 352
 353    type Acc_Size
 354      is access function (A : System.Address) return Long_Long_Integer;
 355
 356    function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size);
 357    --  The profile of the implicitly defined _size primitive
 358
 359    type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset;
 360
 361    function To_Storage_Offset_Ptr is
 362      new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
 363
 364    -----------------------
 365    -- Local Subprograms --
 366    -----------------------
 367
 368    function Check_Index
 369      (T     : Tag;
 370       Index : Natural) return Boolean;
 371    --  Check that Index references a valid entry of the dispatch table of T
 372
 373    function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean;
 374    --  Check that the signature of T is valid and corresponds with the subset
 375    --  specified by the signature Kind.
 376
 377    function Check_Size
 378      (Old_T       : Tag;
 379       New_T       : Tag;
 380       Entry_Count : Natural) return Boolean;
 381    --  Verify that Old_T and New_T have at least Entry_Count entries
 382
 383    function Get_Num_Prim_Ops (T : Tag) return Natural;
 384    --  Retrieve the number of primitive operations in the dispatch table of T
 385
 386    function Is_Primary_DT (T : Tag) return Boolean;
 387    pragma Inline_Always (Is_Primary_DT);
 388    --  Given a tag returns True if it has the signature of a primary dispatch
 389    --  table.  This is Inline_Always since it is called from other Inline_
 390    --  Always subprograms where we want no out of line code to be generated.
 391
 392    function Length (Str : Cstring_Ptr) return Natural;
 393    --  Length of string represented by the given pointer (treating the string
 394    --  as a C-style string, which is Nul terminated).
 395
 396    function Typeinfo_Ptr (T : Tag) return System.Address;
 397    --  Returns the current value of the typeinfo_ptr component available in
 398    --  the prologue of the dispatch table.
 399
 400    pragma Unreferenced (Typeinfo_Ptr);
 401    --  These functions will be used for full compatibility with the C++ ABI
 402
 403    -------------------------
 404    -- External_Tag_HTable --
 405    -------------------------
 406
 407    type HTable_Headers is range 1 .. 64;
 408
 409    --  The following internal package defines the routines used for the
 410    --  instantiation of a new System.HTable.Static_HTable (see below). See
 411    --  spec in g-htable.ads for details of usage.
 412
 413    package HTable_Subprograms is
 414       procedure Set_HT_Link (T : Tag; Next : Tag);
 415       function  Get_HT_Link (T : Tag) return Tag;
 416       function Hash (F : System.Address) return HTable_Headers;
 417       function Equal (A, B : System.Address) return Boolean;
 418    end HTable_Subprograms;
 419
 420    package External_Tag_HTable is new System.HTable.Static_HTable (
 421      Header_Num => HTable_Headers,
 422      Element    => Dispatch_Table,
 423      Elmt_Ptr   => Tag,
 424      Null_Ptr   => null,
 425      Set_Next   => HTable_Subprograms.Set_HT_Link,
 426      Next       => HTable_Subprograms.Get_HT_Link,
 427      Key        => System.Address,
 428      Get_Key    => Get_External_Tag,
 429      Hash       => HTable_Subprograms.Hash,
 430      Equal      => HTable_Subprograms.Equal);
 431
 432    ------------------------
 433    -- HTable_Subprograms --
 434    ------------------------
 435
 436    --  Bodies of routines for hash table instantiation
 437
 438    package body HTable_Subprograms is
 439
 440       -----------
 441       -- Equal --
 442       -----------
 443
 444       function Equal (A, B : System.Address) return Boolean is
 445          Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
 446          Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
 447          J    : Integer := 1;
 448       begin
 449          loop
 450             if Str1 (J) /= Str2 (J) then
 451                return False;
 452             elsif Str1 (J) = ASCII.NUL then
 453                return True;
 454             else
 455                J := J + 1;
 456             end if;
 457          end loop;
 458       end Equal;
 459
 460       -----------------
 461       -- Get_HT_Link --
 462       -----------------
 463
 464       function Get_HT_Link (T : Tag) return Tag is
 465       begin
 466          return TSD (T).HT_Link;
 467       end Get_HT_Link;
 468
 469       ----------
 470       -- Hash --
 471       ----------
 472
 473       function Hash (F : System.Address) return HTable_Headers is
 474          function H is new System.HTable.Hash (HTable_Headers);
 475          Str : constant Cstring_Ptr    := To_Cstring_Ptr (F);
 476          Res : constant HTable_Headers := H (Str (1 .. Length (Str)));
 477       begin
 478          return Res;
 479       end Hash;
 480
 481       -----------------
 482       -- Set_HT_Link --
 483       -----------------
 484
 485       procedure Set_HT_Link (T : Tag; Next : Tag) is
 486       begin
 487          TSD (T).HT_Link := Next;
 488       end Set_HT_Link;
 489
 490    end HTable_Subprograms;
 491
 492    -----------------
 493    -- Check_Index --
 494    -----------------
 495
 496    function Check_Index
 497      (T     : Tag;
 498       Index : Natural) return Boolean
 499    is
 500       Max_Entries : constant Natural := Get_Num_Prim_Ops (T);
 501
 502    begin
 503       return Index /= 0 and then Index <= Max_Entries;
 504    end Check_Index;
 505
 506    ---------------------
 507    -- Check_Signature --
 508    ---------------------
 509
 510    function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean is
 511       Signature : constant Storage_Offset_Ptr :=
 512                     To_Storage_Offset_Ptr (To_Address (T) - K_Signature);
 513
 514       Sig_Values : constant Signature_Values :=
 515                      To_Signature_Values (Signature.all);
 516
 517       Signature_Id : Signature_Kind;
 518
 519    begin
 520       if Sig_Values (1) /= Valid_Signature then
 521          Signature_Id := Unknown;
 522
 523       elsif Sig_Values (2) in Primary_DT .. Abstract_Interface then
 524          Signature_Id := Sig_Values (2);
 525
 526       else
 527          Signature_Id := Unknown;
 528       end if;
 529
 530       case Signature_Id is
 531          when Primary_DT         =>
 532             if Kind = Must_Be_Secondary_DT
 533               or else Kind = Must_Be_Interface
 534             then
 535                return False;
 536             end if;
 537
 538          when Secondary_DT       =>
 539             if Kind = Must_Be_Primary_DT
 540               or else Kind = Must_Be_Interface
 541             then
 542                return False;
 543             end if;
 544
 545          when Abstract_Interface =>
 546             if Kind = Must_Be_Primary_DT
 547               or else Kind = Must_Be_Secondary_DT
 548               or else Kind = Must_Be_Primary_Or_Secondary_DT
 549             then
 550                return False;
 551             end if;
 552
 553          when others =>
 554             return False;
 555
 556       end case;
 557
 558       return True;
 559    end Check_Signature;
 560
 561    ----------------
 562    -- Check_Size --
 563    ----------------
 564
 565    function Check_Size
 566      (Old_T       : Tag;
 567       New_T       : Tag;
 568       Entry_Count : Natural) return Boolean
 569    is
 570       Max_Entries_Old : constant Natural := Get_Num_Prim_Ops (Old_T);
 571       Max_Entries_New : constant Natural := Get_Num_Prim_Ops (New_T);
 572
 573    begin
 574       return Entry_Count <= Max_Entries_Old
 575         and then Entry_Count <= Max_Entries_New;
 576    end Check_Size;
 577
 578    -------------------
 579    -- CW_Membership --
 580    -------------------
 581
 582    --  Canonical implementation of Classwide Membership corresponding to:
 583
 584    --     Obj in Typ'Class
 585
 586    --  Each dispatch table contains a reference to a table of ancestors (stored
 587    --  in the first part of the Tags_Table) and a count of the level of
 588    --  inheritance "Idepth".
 589
 590    --  Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
 591    --  contained in the dispatch table referenced by Obj'Tag . Knowing the
 592    --  level of inheritance of both types, this can be computed in constant
 593    --  time by the formula:
 594
 595    --   Obj'tag.TSD.Ancestor_Tags (Obj'tag.TSD.Idepth - Typ'tag.TSD.Idepth)
 596    --     = Typ'tag
 597
 598    function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
 599       Pos : Integer;
 600    begin
 601       pragma Assert (Check_Signature (Obj_Tag, Must_Be_Primary_DT));
 602       pragma Assert (Check_Signature (Typ_Tag, Must_Be_Primary_DT));
 603       Pos := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
 604       return Pos >= 0 and then TSD (Obj_Tag).Tags_Table (Pos) = Typ_Tag;
 605    end CW_Membership;
 606
 607    --------------
 608    -- Displace --
 609    --------------
 610
 611    function Displace
 612      (This : System.Address;
 613       T    : Tag) return System.Address
 614    is
 615       Curr_DT     : constant Tag := To_Tag_Ptr (This).all;
 616       Iface_Table : Interface_Data_Ptr;
 617       Obj_Base    : System.Address;
 618       Obj_DT      : Tag;
 619       Obj_TSD     : Type_Specific_Data_Ptr;
 620
 621    begin
 622       pragma Assert
 623         (Check_Signature (Curr_DT, Must_Be_Primary_Or_Secondary_DT));
 624       pragma Assert
 625         (Check_Signature (T, Must_Be_Interface));
 626
 627       Obj_Base    := This - Offset_To_Top (Curr_DT);
 628       Obj_DT      := To_Tag_Ptr (Obj_Base).all;
 629
 630       pragma Assert
 631         (Check_Signature (Obj_DT, Must_Be_Primary_DT));
 632
 633       Obj_TSD     := TSD (Obj_DT);
 634       Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
 635
 636       if Iface_Table /= null then
 637          for Id in 1 .. Iface_Table.Nb_Ifaces loop
 638             if Iface_Table.Table (Id).Iface_Tag = T then
 639                Obj_Base := Obj_Base + Iface_Table.Table (Id).Offset;
 640                Obj_DT   := To_Tag_Ptr (Obj_Base).all;
 641
 642                pragma Assert
 643                  (Check_Signature (Obj_DT, Must_Be_Secondary_DT));
 644
 645                return Obj_Base;
 646             end if;
 647          end loop;
 648       end if;
 649
 650       --  If the object does not implement the interface we must raise CE
 651
 652       raise Constraint_Error;
 653    end Displace;
 654
 655    -------------------
 656    -- IW_Membership --
 657    -------------------
 658
 659    --  Canonical implementation of Classwide Membership corresponding to:
 660
 661    --     Obj in Iface'Class
 662
 663    --  Each dispatch table contains a table with the tags of all the
 664    --  implemented interfaces.
 665
 666    --  Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
 667    --  that are contained in the dispatch table referenced by Obj'Tag.
 668
 669    function IW_Membership (This : System.Address; T : Tag) return Boolean is
 670       Curr_DT     : constant Tag := To_Tag_Ptr (This).all;
 671       Iface_Table : Interface_Data_Ptr;
 672       Last_Id     : Natural;
 673       Obj_Base    : System.Address;
 674       Obj_DT      : Tag;
 675       Obj_TSD     : Type_Specific_Data_Ptr;
 676
 677    begin
 678       pragma Assert
 679         (Check_Signature (Curr_DT, Must_Be_Primary_Or_Secondary_DT));
 680       pragma Assert
 681         (Check_Signature (T, Must_Be_Primary_Or_Interface));
 682
 683       Obj_Base := This - Offset_To_Top (Curr_DT);
 684       Obj_DT   := To_Tag_Ptr (Obj_Base).all;
 685
 686       pragma Assert
 687         (Check_Signature (Obj_DT, Must_Be_Primary_DT));
 688
 689       Obj_TSD := TSD (Obj_DT);
 690       Last_Id := Obj_TSD.Idepth;
 691
 692       --  Look for the tag in the table of interfaces
 693
 694       Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
 695
 696       if Iface_Table /= null then
 697          for Id in 1 .. Iface_Table.Nb_Ifaces loop
 698             if Iface_Table.Table (Id).Iface_Tag = T then
 699                return True;
 700             end if;
 701          end loop;
 702       end if;
 703
 704       --  Look for the tag in the ancestor tags table. This is required for:
 705       --     Iface_CW in Typ'Class
 706
 707       for Id in 0 .. Last_Id loop
 708          if Obj_TSD.Tags_Table (Id) = T then
 709             return True;
 710          end if;
 711       end loop;
 712
 713       return False;
 714    end IW_Membership;
 715
 716    --------------------
 717    -- Descendant_Tag --
 718    --------------------
 719
 720    function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
 721       Int_Tag : Tag;
 722
 723    begin
 724       pragma Assert (Check_Signature (Ancestor, Must_Be_Primary_DT));
 725       Int_Tag := Internal_Tag (External);
 726       pragma Assert (Check_Signature (Int_Tag, Must_Be_Primary_DT));
 727
 728       if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
 729          raise Tag_Error;
 730       end if;
 731
 732       return Int_Tag;
 733    end Descendant_Tag;
 734
 735    -------------------
 736    -- Expanded_Name --
 737    -------------------
 738
 739    function Expanded_Name (T : Tag) return String is
 740       Result : Cstring_Ptr;
 741
 742    begin
 743       if T = No_Tag then
 744          raise Tag_Error;
 745       end if;
 746
 747       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
 748       Result := TSD (T).Expanded_Name;
 749       return Result (1 .. Length (Result));
 750    end Expanded_Name;
 751
 752    ------------------
 753    -- External_Tag --
 754    ------------------
 755
 756    function External_Tag (T : Tag) return String is
 757       Result : Cstring_Ptr;
 758
 759    begin
 760       if T = No_Tag then
 761          raise Tag_Error;
 762       end if;
 763
 764       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
 765       Result := TSD (T).External_Tag;
 766
 767       return Result (1 .. Length (Result));
 768    end External_Tag;
 769
 770    ----------------------
 771    -- Get_Access_Level --
 772    ----------------------
 773
 774    function Get_Access_Level (T : Tag) return Natural is
 775    begin
 776       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 777       return TSD (T).Access_Level;
 778    end Get_Access_Level;
 779
 780    ---------------------
 781    -- Get_Entry_Index --
 782    ---------------------
 783
 784    function Get_Entry_Index (T : Tag; Position : Positive) return Positive is
 785       Index : constant Integer := Position - Default_Prim_Op_Count;
 786    begin
 787       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 788       pragma Assert (Check_Index (T, Position));
 789       pragma Assert (Index > 0);
 790       return SSD (T).SSD_Table (Index).Index;
 791    end Get_Entry_Index;
 792
 793    ----------------------
 794    -- Get_External_Tag --
 795    ----------------------
 796
 797    function Get_External_Tag (T : Tag) return System.Address is
 798    begin
 799       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 800       return To_Address (TSD (T).External_Tag);
 801    end Get_External_Tag;
 802
 803    ----------------------
 804    -- Get_Num_Prim_Ops --
 805    ----------------------
 806
 807    function Get_Num_Prim_Ops (T : Tag) return Natural is
 808    begin
 809       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
 810
 811       if Is_Primary_DT (T) then
 812          return TSD (T).Num_Prim_Ops;
 813       else
 814          return OSD (T).Num_Prim_Ops;
 815       end if;
 816    end Get_Num_Prim_Ops;
 817
 818    -------------------------
 819    -- Get_Prim_Op_Address --
 820    -------------------------
 821
 822    function Get_Prim_Op_Address
 823      (T        : Tag;
 824       Position : Positive) return System.Address
 825    is
 826    begin
 827       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
 828       pragma Assert (Check_Index (T, Position));
 829       return T.Prims_Ptr (Position);
 830    end Get_Prim_Op_Address;
 831
 832    ----------------------
 833    -- Get_Prim_Op_Kind --
 834    ----------------------
 835
 836    function Get_Prim_Op_Kind
 837      (T        : Tag;
 838       Position : Positive) return Prim_Op_Kind
 839    is
 840       Index : constant Integer := Position - Default_Prim_Op_Count;
 841    begin
 842       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 843       pragma Assert (Check_Index (T, Position));
 844       pragma Assert (Index > 0);
 845       return SSD (T).SSD_Table (Index).Kind;
 846    end Get_Prim_Op_Kind;
 847
 848    ----------------------
 849    -- Get_Offset_Index --
 850    ----------------------
 851
 852    function Get_Offset_Index
 853      (T        : Tag;
 854       Position : Positive) return Positive
 855    is
 856       Index : constant Integer := Position - Default_Prim_Op_Count;
 857    begin
 858       pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
 859       pragma Assert (Check_Index (T, Position));
 860       pragma Assert (Index > 0);
 861       return OSD (T).OSD_Table (Index);
 862    end Get_Offset_Index;
 863
 864    -------------------
 865    -- Get_RC_Offset --
 866    -------------------
 867
 868    function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is
 869    begin
 870       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 871       return TSD (T).RC_Offset;
 872    end Get_RC_Offset;
 873
 874    ---------------------------
 875    -- Get_Remotely_Callable --
 876    ---------------------------
 877
 878    function Get_Remotely_Callable (T : Tag) return Boolean is
 879    begin
 880       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 881       return TSD (T).Remotely_Callable;
 882    end Get_Remotely_Callable;
 883
 884    ---------------------
 885    -- Get_Tagged_Kind --
 886    ---------------------
 887
 888    function Get_Tagged_Kind (T : Tag) return Tagged_Kind is
 889       Tagged_Kind_Ptr : constant System.Address :=
 890                           To_Address (T) - K_Tagged_Kind;
 891    begin
 892       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
 893       return To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all;
 894    end Get_Tagged_Kind;
 895
 896    ----------------
 897    -- Inherit_DT --
 898    ----------------
 899
 900    procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural) is
 901    begin
 902       pragma Assert (Check_Signature (Old_T, Must_Be_Primary_Or_Secondary_DT));
 903       pragma Assert (Check_Signature (New_T, Must_Be_Primary_Or_Secondary_DT));
 904       pragma Assert (Check_Size (Old_T, New_T, Entry_Count));
 905
 906       if Old_T /= null then
 907          New_T.Prims_Ptr (1 .. Entry_Count) :=
 908            Old_T.Prims_Ptr (1 .. Entry_Count);
 909       end if;
 910    end Inherit_DT;
 911
 912    -----------------
 913    -- Inherit_TSD --
 914    -----------------
 915
 916    procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag) is
 917       New_TSD_Ptr         : Type_Specific_Data_Ptr;
 918       New_Iface_Table_Ptr : Interface_Data_Ptr;
 919       Old_TSD_Ptr         : Type_Specific_Data_Ptr;
 920       Old_Iface_Table_Ptr : Interface_Data_Ptr;
 921
 922    begin
 923       pragma Assert (Check_Signature (New_Tag, Must_Be_Primary_Or_Interface));
 924       New_TSD_Ptr := TSD (New_Tag);
 925
 926       if Old_Tag /= null then
 927          pragma Assert
 928            (Check_Signature (Old_Tag, Must_Be_Primary_Or_Interface));
 929          Old_TSD_Ptr := TSD (Old_Tag);
 930          New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1;
 931
 932          --  Copy the "table of ancestor tags" plus the "table of interfaces"
 933          --  of the parent.
 934
 935          New_TSD_Ptr.Tags_Table (1 .. New_TSD_Ptr.Idepth) :=
 936            Old_TSD_Ptr.Tags_Table (0 .. Old_TSD_Ptr.Idepth);
 937
 938          --  Copy the table of interfaces of the parent
 939
 940          if not System."=" (Old_TSD_Ptr.Ifaces_Table_Ptr,
 941                             System.Null_Address)
 942          then
 943             Old_Iface_Table_Ptr :=
 944               To_Interface_Data_Ptr (Old_TSD_Ptr.Ifaces_Table_Ptr);
 945             New_Iface_Table_Ptr :=
 946               To_Interface_Data_Ptr (New_TSD_Ptr.Ifaces_Table_Ptr);
 947
 948             New_Iface_Table_Ptr.Table (1 .. Old_Iface_Table_Ptr.Nb_Ifaces) :=
 949               Old_Iface_Table_Ptr.Table (1 .. Old_Iface_Table_Ptr.Nb_Ifaces);
 950          end if;
 951
 952       else
 953          New_TSD_Ptr.Idepth := 0;
 954       end if;
 955
 956       New_TSD_Ptr.Tags_Table (0) := New_Tag;
 957    end Inherit_TSD;
 958
 959    ------------------
 960    -- Internal_Tag --
 961    ------------------
 962
 963    function Internal_Tag (External : String) return Tag is
 964       Ext_Copy : aliased String (External'First .. External'Last + 1);
 965       Res      : Tag;
 966
 967    begin
 968       --  Make a copy of the string representing the external tag with
 969       --  a null at the end.
 970
 971       Ext_Copy (External'Range) := External;
 972       Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
 973       Res := External_Tag_HTable.Get (Ext_Copy'Address);
 974
 975       if Res = null then
 976          declare
 977             Msg1 : constant String := "unknown tagged type: ";
 978             Msg2 : String (1 .. Msg1'Length + External'Length);
 979
 980          begin
 981             Msg2 (1 .. Msg1'Length) := Msg1;
 982             Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
 983               External;
 984             Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2);
 985          end;
 986       end if;
 987
 988       return Res;
 989    end Internal_Tag;
 990
 991    ---------------------------------
 992    -- Is_Descendant_At_Same_Level --
 993    ---------------------------------
 994
 995    function Is_Descendant_At_Same_Level
 996      (Descendant : Tag;
 997       Ancestor   : Tag) return Boolean
 998    is
 999    begin
1000       return CW_Membership (Descendant, Ancestor)
1001         and then TSD (Descendant).Access_Level = TSD (Ancestor).Access_Level;
1002    end Is_Descendant_At_Same_Level;
1003
1004    -------------------
1005    -- Is_Primary_DT --
1006    -------------------
1007
1008    function Is_Primary_DT (T : Tag) return Boolean is
1009       Signature  : constant Storage_Offset_Ptr :=
1010                      To_Storage_Offset_Ptr (To_Address (T) - K_Signature);
1011       Sig_Values : constant Signature_Values :=
1012                      To_Signature_Values (Signature.all);
1013    begin
1014       return Sig_Values (2) = Primary_DT;
1015    end Is_Primary_DT;
1016
1017    ------------
1018    -- Length --
1019    ------------
1020
1021    function Length (Str : Cstring_Ptr) return Natural is
1022       Len : Integer := 1;
1023
1024    begin
1025       while Str (Len) /= ASCII.Nul loop
1026          Len := Len + 1;
1027       end loop;
1028
1029       return Len - 1;
1030    end Length;
1031
1032    -------------------
1033    -- Offset_To_Top --
1034    -------------------
1035
1036    function Offset_To_Top
1037      (T : Tag) return System.Storage_Elements.Storage_Offset
1038    is
1039       Offset_To_Top : constant Storage_Offset_Ptr :=
1040                         To_Storage_Offset_Ptr
1041                           (To_Address (T) - K_Offset_To_Top);
1042    begin
1043       return Offset_To_Top.all;
1044    end Offset_To_Top;
1045
1046    ---------
1047    -- OSD --
1048    ---------
1049
1050    function OSD (T : Tag) return Object_Specific_Data_Ptr is
1051       OSD_Ptr : constant Addr_Ptr :=
1052                   To_Addr_Ptr (To_Address (T) - K_Typeinfo);
1053    begin
1054       pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
1055       return To_Object_Specific_Data_Ptr (OSD_Ptr.all);
1056    end OSD;
1057
1058    -----------------
1059    -- Parent_Size --
1060    -----------------
1061
1062    function Parent_Size
1063      (Obj : System.Address;
1064       T   : Tag) return SSE.Storage_Count
1065    is
1066       Parent_Tag : Tag;
1067       --  The tag of the parent type through the dispatch table
1068
1069       F : Acc_Size;
1070       --  Access to the _size primitive of the parent. We assume that it is
1071       --  always in the first slot of the dispatch table.
1072
1073    begin
1074       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1075       Parent_Tag := TSD (T).Tags_Table (1);
1076       F := To_Acc_Size (Parent_Tag.Prims_Ptr (1));
1077
1078       --  Here we compute the size of the _parent field of the object
1079
1080       return SSE.Storage_Count (F.all (Obj));
1081    end Parent_Size;
1082
1083    ----------------
1084    -- Parent_Tag --
1085    ----------------
1086
1087    function Parent_Tag (T : Tag) return Tag is
1088    begin
1089       if T = No_Tag then
1090          raise Tag_Error;
1091       end if;
1092
1093       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1094
1095       --  The Parent_Tag of a root-level tagged type is defined to be No_Tag.
1096       --  The first entry in the Ancestors_Tags array will be null for such
1097       --  a type, but it's better to be explicit about returning No_Tag in
1098       --  this case.
1099
1100       if TSD (T).Idepth = 0 then
1101          return No_Tag;
1102       else
1103          return TSD (T).Tags_Table (1);
1104       end if;
1105    end Parent_Tag;
1106
1107    ----------------------------
1108    -- Register_Interface_Tag --
1109    ----------------------------
1110
1111    procedure Register_Interface_Tag
1112      (T           : Tag;
1113       Interface_T : Tag;
1114       Position    : Positive)
1115    is
1116       New_T_TSD   : Type_Specific_Data_Ptr;
1117       Iface_Table : Interface_Data_Ptr;
1118
1119    begin
1120       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1121       pragma Assert (Check_Signature (Interface_T, Must_Be_Interface));
1122
1123       New_T_TSD   := TSD (T);
1124       Iface_Table := To_Interface_Data_Ptr (New_T_TSD.Ifaces_Table_Ptr);
1125
1126       pragma Assert (Position <= Iface_Table.Nb_Ifaces);
1127
1128       Iface_Table.Table (Position).Iface_Tag := Interface_T;
1129    end Register_Interface_Tag;
1130
1131    ------------------
1132    -- Register_Tag --
1133    ------------------
1134
1135    procedure Register_Tag (T : Tag) is
1136    begin
1137       External_Tag_HTable.Set (T);
1138    end Register_Tag;
1139
1140    ----------------------
1141    -- Set_Access_Level --
1142    ----------------------
1143
1144    procedure Set_Access_Level (T : Tag; Value : Natural) is
1145    begin
1146       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1147       TSD (T).Access_Level := Value;
1148    end Set_Access_Level;
1149
1150    ---------------------
1151    -- Set_Entry_Index --
1152    ---------------------
1153
1154    procedure Set_Entry_Index
1155      (T        : Tag;
1156       Position : Positive;
1157       Value    : Positive)
1158    is
1159       Index : constant Integer := Position - Default_Prim_Op_Count;
1160    begin
1161       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1162       pragma Assert (Check_Index (T, Position));
1163       pragma Assert (Index > 0);
1164       SSD (T).SSD_Table (Index).Index := Value;
1165    end Set_Entry_Index;
1166
1167    -----------------------
1168    -- Set_Expanded_Name --
1169    -----------------------
1170
1171    procedure Set_Expanded_Name (T : Tag; Value : System.Address) is
1172    begin
1173       pragma Assert
1174         (Check_Signature (T, Must_Be_Primary_Or_Interface));
1175       TSD (T).Expanded_Name := To_Cstring_Ptr (Value);
1176    end Set_Expanded_Name;
1177
1178    ----------------------
1179    -- Set_External_Tag --
1180    ----------------------
1181
1182    procedure Set_External_Tag (T : Tag; Value : System.Address) is
1183    begin
1184       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
1185       TSD (T).External_Tag := To_Cstring_Ptr (Value);
1186    end Set_External_Tag;
1187
1188    -------------------------
1189    -- Set_Interface_Table --
1190    -------------------------
1191
1192    procedure Set_Interface_Table (T : Tag; Value : System.Address) is
1193    begin
1194       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1195       TSD (T).Ifaces_Table_Ptr := Value;
1196    end Set_Interface_Table;
1197
1198    ----------------------
1199    -- Set_Num_Prim_Ops --
1200    ----------------------
1201
1202    procedure Set_Num_Prim_Ops (T : Tag; Value : Natural) is
1203    begin
1204       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
1205
1206       if Is_Primary_DT (T) then
1207          TSD (T).Num_Prim_Ops := Value;
1208       else
1209          OSD (T).Num_Prim_Ops := Value;
1210       end if;
1211    end Set_Num_Prim_Ops;
1212
1213    ----------------------
1214    -- Set_Offset_Index --
1215    ----------------------
1216
1217    procedure Set_Offset_Index
1218      (T        : Tag;
1219       Position : Positive;
1220       Value    : Positive)
1221    is
1222       Index : constant Integer := Position - Default_Prim_Op_Count;
1223    begin
1224       pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
1225       pragma Assert (Check_Index (T, Position));
1226       pragma Assert (Index > 0);
1227       OSD (T).OSD_Table (Index) := Value;
1228    end Set_Offset_Index;
1229
1230    -----------------------
1231    -- Set_Offset_To_Top --
1232    -----------------------
1233
1234    procedure Set_Offset_To_Top
1235      (This          : System.Address;
1236       Interface_T   : Tag;
1237       Offset_Value  : System.Storage_Elements.Storage_Offset)
1238    is
1239       Prim_DT       : Tag;
1240       Sec_Base      : System.Address;
1241       Sec_DT        : Tag;
1242       Offset_To_Top : Storage_Offset_Ptr;
1243       Iface_Table   : Interface_Data_Ptr;
1244       Obj_TSD       : Type_Specific_Data_Ptr;
1245    begin
1246       if System."=" (This, System.Null_Address) then
1247          pragma Assert
1248            (Check_Signature (Interface_T, Must_Be_Primary_DT));
1249          pragma Assert (Offset_Value = 0);
1250
1251          Offset_To_Top :=
1252            To_Storage_Offset_Ptr (To_Address (Interface_T) - K_Offset_To_Top);
1253          Offset_To_Top.all := Offset_Value;
1254          return;
1255       end if;
1256
1257       --  "This" points to the primary DT and we must save Offset_Value in the
1258       --  Offset_To_Top field of the corresponding secondary dispatch table.
1259
1260       Prim_DT := To_Tag_Ptr (This).all;
1261
1262       pragma Assert
1263         (Check_Signature (Prim_DT, Must_Be_Primary_DT));
1264
1265       Sec_Base := This + Offset_Value;
1266       Sec_DT   := To_Tag_Ptr (Sec_Base).all;
1267       Offset_To_Top :=
1268         To_Storage_Offset_Ptr (To_Address (Sec_DT) - K_Offset_To_Top);
1269
1270       pragma Assert
1271         (Check_Signature (Sec_DT, Must_Be_Primary_Or_Secondary_DT));
1272
1273       Offset_To_Top.all := Offset_Value;
1274
1275       --  Save Offset_Value in the table of interfaces of the primary DT. This
1276       --  data will be used by the subprogram "Displace" to give support to
1277       --  backward abstract interface type conversions.
1278
1279       Obj_TSD     := TSD (Prim_DT);
1280       Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
1281
1282       --  Register the offset in the table of interfaces
1283
1284       if Iface_Table /= null then
1285          for Id in 1 .. Iface_Table.Nb_Ifaces loop
1286             if Iface_Table.Table (Id).Iface_Tag = Interface_T then
1287                Iface_Table.Table (Id).Offset := Offset_Value;
1288                return;
1289             end if;
1290          end loop;
1291       end if;
1292
1293       --  If we arrive here there is some error in the run-time data structure
1294
1295       raise Program_Error;
1296    end Set_Offset_To_Top;
1297
1298    -------------
1299    -- Set_OSD --
1300    -------------
1301
1302    procedure Set_OSD (T : Tag; Value : System.Address) is
1303       OSD_Ptr : constant Addr_Ptr :=
1304                   To_Addr_Ptr (To_Address (T) - K_Typeinfo);
1305    begin
1306       pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
1307       OSD_Ptr.all := Value;
1308    end Set_OSD;
1309
1310    -------------------------
1311    -- Set_Prim_Op_Address --
1312    -------------------------
1313
1314    procedure Set_Prim_Op_Address
1315      (T        : Tag;
1316       Position : Positive;
1317       Value    : System.Address)
1318    is
1319    begin
1320       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
1321       pragma Assert (Check_Index (T, Position));
1322       T.Prims_Ptr (Position) := Value;
1323    end Set_Prim_Op_Address;
1324
1325    ----------------------
1326    -- Set_Prim_Op_Kind --
1327    ----------------------
1328
1329    procedure Set_Prim_Op_Kind
1330      (T        : Tag;
1331       Position : Positive;
1332       Value    : Prim_Op_Kind)
1333    is
1334       Index : constant Integer := Position - Default_Prim_Op_Count;
1335    begin
1336       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1337       pragma Assert (Check_Index (T, Position));
1338       pragma Assert (Index > 0);
1339       SSD (T).SSD_Table (Index).Kind := Value;
1340    end Set_Prim_Op_Kind;
1341
1342    -------------------
1343    -- Set_RC_Offset --
1344    -------------------
1345
1346    procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is
1347    begin
1348       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1349       TSD (T).RC_Offset := Value;
1350    end Set_RC_Offset;
1351
1352    ---------------------------
1353    -- Set_Remotely_Callable --
1354    ---------------------------
1355
1356    procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is
1357    begin
1358       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1359       TSD (T).Remotely_Callable := Value;
1360    end Set_Remotely_Callable;
1361
1362    -------------
1363    -- Set_SSD --
1364    -------------
1365
1366    procedure Set_SSD (T : Tag; Value : System.Address) is
1367    begin
1368       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1369       TSD (T).SSD_Ptr := Value;
1370    end Set_SSD;
1371
1372    ---------------------
1373    -- Set_Tagged_Kind --
1374    ---------------------
1375
1376    procedure Set_Tagged_Kind (T : Tag; Value : Tagged_Kind) is
1377       Tagged_Kind_Ptr : constant System.Address :=
1378                           To_Address (T) - K_Tagged_Kind;
1379    begin
1380       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
1381       To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all := Value;
1382    end Set_Tagged_Kind;
1383
1384    -------------
1385    -- Set_TSD --
1386    -------------
1387
1388    procedure Set_TSD (T : Tag; Value : System.Address) is
1389       TSD_Ptr : Addr_Ptr;
1390    begin
1391       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
1392       TSD_Ptr := To_Addr_Ptr (To_Address (T) - K_Typeinfo);
1393       TSD_Ptr.all := Value;
1394    end Set_TSD;
1395
1396    ---------
1397    -- SSD --
1398    ---------
1399
1400    function SSD (T : Tag) return Select_Specific_Data_Ptr is
1401    begin
1402       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1403       return To_Select_Specific_Data_Ptr (TSD (T).SSD_Ptr);
1404    end SSD;
1405
1406    ------------------
1407    -- Typeinfo_Ptr --
1408    ------------------
1409
1410    function Typeinfo_Ptr (T : Tag) return System.Address is
1411       TSD_Ptr : constant Addr_Ptr :=
1412                   To_Addr_Ptr (To_Address (T) - K_Typeinfo);
1413    begin
1414       return TSD_Ptr.all;
1415    end Typeinfo_Ptr;
1416
1417    ---------
1418    -- TSD --
1419    ---------
1420
1421    function TSD (T : Tag) return Type_Specific_Data_Ptr is
1422       TSD_Ptr : constant Addr_Ptr :=
1423                   To_Addr_Ptr (To_Address (T) - K_Typeinfo);
1424    begin
1425       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
1426       return To_Type_Specific_Data_Ptr (TSD_Ptr.all);
1427    end TSD;
1428
1429 end Ada.Tags;