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