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 Predefined_DT (T : Tag) return Tag;
 415    pragma Inline_Always (Predefined_DT);
 416    --  Displace the Tag to reference the dispatch table containing the
 417    --  predefined primitives.
 418
 419    function Typeinfo_Ptr (T : Tag) return System.Address;
 420    --  Returns the current value of the typeinfo_ptr component available in
 421    --  the prologue of the dispatch table.
 422
 423    pragma Unreferenced (Typeinfo_Ptr);
 424    --  These functions will be used for full compatibility with the C++ ABI
 425
 426    -------------------------
 427    -- External_Tag_HTable --
 428    -------------------------
 429
 430    type HTable_Headers is range 1 .. 64;
 431
 432    --  The following internal package defines the routines used for the
 433    --  instantiation of a new System.HTable.Static_HTable (see below). See
 434    --  spec in g-htable.ads for details of usage.
 435
 436    package HTable_Subprograms is
 437       procedure Set_HT_Link (T : Tag; Next : Tag);
 438       function  Get_HT_Link (T : Tag) return Tag;
 439       function Hash (F : System.Address) return HTable_Headers;
 440       function Equal (A, B : System.Address) return Boolean;
 441    end HTable_Subprograms;
 442
 443    package External_Tag_HTable is new System.HTable.Static_HTable (
 444      Header_Num => HTable_Headers,
 445      Element    => Dispatch_Table,
 446      Elmt_Ptr   => Tag,
 447      Null_Ptr   => null,
 448      Set_Next   => HTable_Subprograms.Set_HT_Link,
 449      Next       => HTable_Subprograms.Get_HT_Link,
 450      Key        => System.Address,
 451      Get_Key    => Get_External_Tag,
 452      Hash       => HTable_Subprograms.Hash,
 453      Equal      => HTable_Subprograms.Equal);
 454
 455    ------------------------
 456    -- HTable_Subprograms --
 457    ------------------------
 458
 459    --  Bodies of routines for hash table instantiation
 460
 461    package body HTable_Subprograms is
 462
 463       -----------
 464       -- Equal --
 465       -----------
 466
 467       function Equal (A, B : System.Address) return Boolean is
 468          Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
 469          Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
 470          J    : Integer := 1;
 471       begin
 472          loop
 473             if Str1 (J) /= Str2 (J) then
 474                return False;
 475             elsif Str1 (J) = ASCII.NUL then
 476                return True;
 477             else
 478                J := J + 1;
 479             end if;
 480          end loop;
 481       end Equal;
 482
 483       -----------------
 484       -- Get_HT_Link --
 485       -----------------
 486
 487       function Get_HT_Link (T : Tag) return Tag is
 488       begin
 489          return TSD (T).HT_Link;
 490       end Get_HT_Link;
 491
 492       ----------
 493       -- Hash --
 494       ----------
 495
 496       function Hash (F : System.Address) return HTable_Headers is
 497          function H is new System.HTable.Hash (HTable_Headers);
 498          Str : constant Cstring_Ptr    := To_Cstring_Ptr (F);
 499          Res : constant HTable_Headers := H (Str (1 .. Length (Str)));
 500       begin
 501          return Res;
 502       end Hash;
 503
 504       -----------------
 505       -- Set_HT_Link --
 506       -----------------
 507
 508       procedure Set_HT_Link (T : Tag; Next : Tag) is
 509       begin
 510          TSD (T).HT_Link := Next;
 511       end Set_HT_Link;
 512
 513    end HTable_Subprograms;
 514
 515    ---------------------
 516    -- Check_Signature --
 517    ---------------------
 518
 519    function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean is
 520       Signature : constant Storage_Offset_Ptr :=
 521                     To_Storage_Offset_Ptr (To_Address (T) - K_Signature);
 522
 523       Sig_Values : constant Signature_Values :=
 524                      To_Signature_Values (Signature.all);
 525
 526       Signature_Id : Signature_Kind;
 527
 528    begin
 529       if Sig_Values (1) /= Valid_Signature then
 530          Signature_Id := Unknown;
 531
 532       elsif Sig_Values (2) in Primary_DT .. Abstract_Interface then
 533          Signature_Id := Sig_Values (2);
 534
 535       else
 536          Signature_Id := Unknown;
 537       end if;
 538
 539       case Signature_Id is
 540          when Primary_DT         =>
 541             if Kind = Must_Be_Secondary_DT
 542               or else Kind = Must_Be_Interface
 543             then
 544                return False;
 545             end if;
 546
 547          when Secondary_DT       =>
 548             if Kind = Must_Be_Primary_DT
 549               or else Kind = Must_Be_Interface
 550             then
 551                return False;
 552             end if;
 553
 554          when Abstract_Interface =>
 555             if Kind = Must_Be_Primary_DT
 556               or else Kind = Must_Be_Secondary_DT
 557               or else Kind = Must_Be_Primary_Or_Secondary_DT
 558             then
 559                return False;
 560             end if;
 561
 562          when others =>
 563             return False;
 564
 565       end case;
 566
 567       return True;
 568    end Check_Signature;
 569
 570    ----------------
 571    -- Check_Size --
 572    ----------------
 573
 574    function Check_Size
 575      (Old_T       : Tag;
 576       New_T       : Tag;
 577       Entry_Count : Natural) return Boolean
 578    is
 579       Max_Entries_Old : constant Natural := Get_Num_Prim_Ops (Old_T);
 580       Max_Entries_New : constant Natural := Get_Num_Prim_Ops (New_T);
 581
 582    begin
 583       return Entry_Count <= Max_Entries_Old
 584         and then Entry_Count <= Max_Entries_New;
 585    end Check_Size;
 586
 587    -------------------
 588    -- CW_Membership --
 589    -------------------
 590
 591    --  Canonical implementation of Classwide Membership corresponding to:
 592
 593    --     Obj in Typ'Class
 594
 595    --  Each dispatch table contains a reference to a table of ancestors (stored
 596    --  in the first part of the Tags_Table) and a count of the level of
 597    --  inheritance "Idepth".
 598
 599    --  Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
 600    --  contained in the dispatch table referenced by Obj'Tag . Knowing the
 601    --  level of inheritance of both types, this can be computed in constant
 602    --  time by the formula:
 603
 604    --   TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
 605    --     = Typ'tag
 606
 607    function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
 608       Pos : Integer;
 609    begin
 610       pragma Assert (Check_Signature (Obj_Tag, Must_Be_Primary_DT));
 611       pragma Assert (Check_Signature (Typ_Tag, Must_Be_Primary_DT));
 612       Pos := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
 613       return Pos >= 0 and then TSD (Obj_Tag).Tags_Table (Pos) = Typ_Tag;
 614    end CW_Membership;
 615
 616    --------------
 617    -- Displace --
 618    --------------
 619
 620    function Displace
 621      (This : System.Address;
 622       T    : Tag) return System.Address
 623    is
 624       Curr_DT     : constant Tag := To_Tag_Ptr (This).all;
 625       Iface_Table : Interface_Data_Ptr;
 626       Obj_Base    : System.Address;
 627       Obj_DT      : Tag;
 628       Obj_TSD     : Type_Specific_Data_Ptr;
 629
 630    begin
 631       pragma Assert
 632         (Check_Signature (Curr_DT, Must_Be_Primary_Or_Secondary_DT));
 633       pragma Assert
 634         (Check_Signature (T, Must_Be_Interface));
 635
 636       Obj_Base    := This - Offset_To_Top (This);
 637       Obj_DT      := To_Tag_Ptr (Obj_Base).all;
 638
 639       pragma Assert
 640         (Check_Signature (Obj_DT, Must_Be_Primary_DT));
 641
 642       Obj_TSD     := TSD (Obj_DT);
 643       Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
 644
 645       if Iface_Table /= null then
 646          for Id in 1 .. Iface_Table.Nb_Ifaces loop
 647             if Iface_Table.Table (Id).Iface_Tag = T then
 648
 649                --  Case of Static value of Offset_To_Top
 650
 651                if Iface_Table.Table (Id).Static_Offset_To_Top then
 652                   Obj_Base :=
 653                     Obj_Base + Iface_Table.Table (Id).Offset_To_Top_Value;
 654
 655                --  Otherwise we call the function generated by the expander
 656                --  to provide us with this value
 657
 658                else
 659                   Obj_Base :=
 660                     Obj_Base +
 661                       To_Offset_To_Top_Function_Ptr
 662                         (Iface_Table.Table (Id).Offset_To_Top_Func).all
 663                           (Obj_Base);
 664                end if;
 665
 666                Obj_DT := To_Tag_Ptr (Obj_Base).all;
 667
 668                pragma Assert
 669                  (Check_Signature (Obj_DT, Must_Be_Secondary_DT));
 670
 671                return Obj_Base;
 672             end if;
 673          end loop;
 674       end if;
 675
 676       --  Check if T is an immediate ancestor. This is required to handle
 677       --  conversion of class-wide interfaces to tagged types.
 678
 679       if CW_Membership (Obj_DT, T) then
 680          return Obj_Base;
 681       end if;
 682
 683       --  If the object does not implement the interface we must raise CE
 684
 685       raise Constraint_Error;
 686    end Displace;
 687
 688    -------------------
 689    -- IW_Membership --
 690    -------------------
 691
 692    --  Canonical implementation of Classwide Membership corresponding to:
 693
 694    --     Obj in Iface'Class
 695
 696    --  Each dispatch table contains a table with the tags of all the
 697    --  implemented interfaces.
 698
 699    --  Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
 700    --  that are contained in the dispatch table referenced by Obj'Tag.
 701
 702    function IW_Membership (This : System.Address; T : Tag) return Boolean is
 703       Curr_DT     : constant Tag := To_Tag_Ptr (This).all;
 704       Iface_Table : Interface_Data_Ptr;
 705       Last_Id     : Natural;
 706       Obj_Base    : System.Address;
 707       Obj_DT      : Tag;
 708       Obj_TSD     : Type_Specific_Data_Ptr;
 709
 710    begin
 711       pragma Assert
 712         (Check_Signature (Curr_DT, Must_Be_Primary_Or_Secondary_DT));
 713       pragma Assert
 714         (Check_Signature (T, Must_Be_Primary_Or_Interface));
 715
 716       Obj_Base := This - Offset_To_Top (This);
 717       Obj_DT   := To_Tag_Ptr (Obj_Base).all;
 718
 719       pragma Assert
 720         (Check_Signature (Obj_DT, Must_Be_Primary_DT));
 721
 722       Obj_TSD := TSD (Obj_DT);
 723       Last_Id := Obj_TSD.Idepth;
 724
 725       --  Look for the tag in the table of interfaces
 726
 727       Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
 728
 729       if Iface_Table /= null then
 730          for Id in 1 .. Iface_Table.Nb_Ifaces loop
 731             if Iface_Table.Table (Id).Iface_Tag = T then
 732                return True;
 733             end if;
 734          end loop;
 735       end if;
 736
 737       --  Look for the tag in the ancestor tags table. This is required for:
 738       --     Iface_CW in Typ'Class
 739
 740       for Id in 0 .. Last_Id loop
 741          if Obj_TSD.Tags_Table (Id) = T then
 742             return True;
 743          end if;
 744       end loop;
 745
 746       return False;
 747    end IW_Membership;
 748
 749    --------------------
 750    -- Descendant_Tag --
 751    --------------------
 752
 753    function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
 754       Int_Tag : Tag;
 755
 756    begin
 757       pragma Assert (Check_Signature (Ancestor, Must_Be_Primary_DT));
 758       Int_Tag := Internal_Tag (External);
 759       pragma Assert (Check_Signature (Int_Tag, Must_Be_Primary_DT));
 760
 761       if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
 762          raise Tag_Error;
 763       end if;
 764
 765       return Int_Tag;
 766    end Descendant_Tag;
 767
 768    -------------------
 769    -- Expanded_Name --
 770    -------------------
 771
 772    function Expanded_Name (T : Tag) return String is
 773       Result : Cstring_Ptr;
 774
 775    begin
 776       if T = No_Tag then
 777          raise Tag_Error;
 778       end if;
 779
 780       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
 781       Result := TSD (T).Expanded_Name;
 782       return Result (1 .. Length (Result));
 783    end Expanded_Name;
 784
 785    ------------------
 786    -- External_Tag --
 787    ------------------
 788
 789    function External_Tag (T : Tag) return String is
 790       Result : Cstring_Ptr;
 791
 792    begin
 793       if T = No_Tag then
 794          raise Tag_Error;
 795       end if;
 796
 797       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
 798       Result := TSD (T).External_Tag;
 799
 800       return Result (1 .. Length (Result));
 801    end External_Tag;
 802
 803    ----------------------
 804    -- Get_Access_Level --
 805    ----------------------
 806
 807    function Get_Access_Level (T : Tag) return Natural is
 808    begin
 809       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 810       return TSD (T).Access_Level;
 811    end Get_Access_Level;
 812
 813    ---------------------
 814    -- Get_Entry_Index --
 815    ---------------------
 816
 817    function Get_Entry_Index (T : Tag; Position : Positive) return Positive is
 818    begin
 819       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 820       pragma Assert (Position <= Get_Num_Prim_Ops (T));
 821       return SSD (T).SSD_Table (Position).Index;
 822    end Get_Entry_Index;
 823
 824    ----------------------
 825    -- Get_External_Tag --
 826    ----------------------
 827
 828    function Get_External_Tag (T : Tag) return System.Address is
 829    begin
 830       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 831       return To_Address (TSD (T).External_Tag);
 832    end Get_External_Tag;
 833
 834    ----------------------
 835    -- Get_Num_Prim_Ops --
 836    ----------------------
 837
 838    function Get_Num_Prim_Ops (T : Tag) return Natural is
 839    begin
 840       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
 841
 842       if Is_Primary_DT (T) then
 843          return TSD (T).Num_Prim_Ops;
 844       else
 845          return OSD (T).Num_Prim_Ops;
 846       end if;
 847    end Get_Num_Prim_Ops;
 848
 849    --------------------------------
 850    -- Get_Predef_Prim_Op_Address --
 851    --------------------------------
 852
 853    function Get_Predefined_Prim_Op_Address
 854      (T        : Tag;
 855       Position : Positive) return System.Address
 856    is
 857    begin
 858       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
 859       pragma Assert (Position <= Default_Prim_Op_Count);
 860       return Predefined_DT (T).Prims_Ptr (Position);
 861    end Get_Predefined_Prim_Op_Address;
 862
 863    -------------------------
 864    -- Get_Prim_Op_Address --
 865    -------------------------
 866
 867    function Get_Prim_Op_Address
 868      (T        : Tag;
 869       Position : Positive) return System.Address
 870    is
 871    begin
 872       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
 873       pragma Assert (Position <= Get_Num_Prim_Ops (T));
 874       return T.Prims_Ptr (Position);
 875    end Get_Prim_Op_Address;
 876
 877    ----------------------
 878    -- Get_Prim_Op_Kind --
 879    ----------------------
 880
 881    function Get_Prim_Op_Kind
 882      (T        : Tag;
 883       Position : Positive) return Prim_Op_Kind
 884    is
 885    begin
 886       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 887       pragma Assert (Position <= Get_Num_Prim_Ops (T));
 888       return SSD (T).SSD_Table (Position).Kind;
 889    end Get_Prim_Op_Kind;
 890
 891    ----------------------
 892    -- Get_Offset_Index --
 893    ----------------------
 894
 895    function Get_Offset_Index
 896      (T        : Tag;
 897       Position : Positive) return Positive
 898    is
 899    begin
 900       pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
 901       pragma Assert (Position <= Get_Num_Prim_Ops (T));
 902       return OSD (T).OSD_Table (Position);
 903    end Get_Offset_Index;
 904
 905    -------------------
 906    -- Get_RC_Offset --
 907    -------------------
 908
 909    function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is
 910    begin
 911       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 912       return TSD (T).RC_Offset;
 913    end Get_RC_Offset;
 914
 915    ---------------------------
 916    -- Get_Remotely_Callable --
 917    ---------------------------
 918
 919    function Get_Remotely_Callable (T : Tag) return Boolean is
 920    begin
 921       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 922       return TSD (T).Remotely_Callable;
 923    end Get_Remotely_Callable;
 924
 925    ---------------------
 926    -- Get_Tagged_Kind --
 927    ---------------------
 928
 929    function Get_Tagged_Kind (T : Tag) return Tagged_Kind is
 930       Tagged_Kind_Ptr : constant System.Address :=
 931                           To_Address (T) - K_Tagged_Kind;
 932    begin
 933       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
 934       return To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all;
 935    end Get_Tagged_Kind;
 936
 937    --------------------
 938    -- Inherit_CPP_DT --
 939    --------------------
 940
 941    procedure Inherit_CPP_DT
 942      (Old_T       : Tag;
 943       New_T       : Tag;
 944       Entry_Count : Natural)
 945    is
 946    begin
 947       New_T.Prims_Ptr (1 .. Entry_Count) := Old_T.Prims_Ptr (1 .. Entry_Count);
 948    end Inherit_CPP_DT;
 949
 950    ----------------
 951    -- Inherit_DT --
 952    ----------------
 953
 954    procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural) is
 955       subtype All_Predefined_Prims is
 956         Positive range 1 .. Default_Prim_Op_Count;
 957
 958    begin
 959       pragma Assert (Check_Signature (Old_T, Must_Be_Primary_Or_Secondary_DT));
 960       pragma Assert (Check_Signature (New_T, Must_Be_Primary_Or_Secondary_DT));
 961       pragma Assert (Check_Size (Old_T, New_T, Entry_Count));
 962
 963       if Old_T /= null then
 964
 965          --  Inherit the primitives of the parent
 966
 967          New_T.Prims_Ptr (1 .. Entry_Count) :=
 968            Old_T.Prims_Ptr (1 .. Entry_Count);
 969
 970          --  Inherit the predefined primitives of the parent
 971
 972          --  NOTE: In the following assignment we have to unactivate a warning
 973          --  generated by the compiler because of the following declaration of
 974          --  the Dispatch_Table:
 975
 976          --      Prims_Ptr : Address_Array (1 .. 1);
 977
 978          --  This is a dummy declaration that is expanded by the frontend to
 979          --  the correct size of the dispatch table corresponding with each
 980          --  tagged type. As a consequence, if we try to use a constant to
 981          --  copy the predefined elements (ie.  Prims_Ptr (1 .. 15) := ...)
 982          --  the compiler generates a warning indicating that Constraint_Error
 983          --  will be raised at run-time (which is not true in this specific
 984          --  case).
 985
 986          pragma Warnings (Off);
 987          Predefined_DT (New_T).Prims_Ptr (All_Predefined_Prims) :=
 988            Predefined_DT (Old_T).Prims_Ptr (All_Predefined_Prims);
 989          pragma Warnings (On);
 990       end if;
 991    end Inherit_DT;
 992
 993    -----------------
 994    -- Inherit_TSD --
 995    -----------------
 996
 997    procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag) is
 998       New_TSD_Ptr         : Type_Specific_Data_Ptr;
 999       New_Iface_Table_Ptr : Interface_Data_Ptr;
1000       Old_TSD_Ptr         : Type_Specific_Data_Ptr;
1001       Old_Iface_Table_Ptr : Interface_Data_Ptr;
1002
1003    begin
1004       pragma Assert (Check_Signature (New_Tag, Must_Be_Primary_Or_Interface));
1005       New_TSD_Ptr := TSD (New_Tag);
1006
1007       if Old_Tag /= null then
1008          pragma Assert
1009            (Check_Signature (Old_Tag, Must_Be_Primary_Or_Interface));
1010          Old_TSD_Ptr := TSD (Old_Tag);
1011          New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1;
1012
1013          --  Copy the "table of ancestor tags" plus the "table of interfaces"
1014          --  of the parent.
1015
1016          New_TSD_Ptr.Tags_Table (1 .. New_TSD_Ptr.Idepth) :=
1017            Old_TSD_Ptr.Tags_Table (0 .. Old_TSD_Ptr.Idepth);
1018
1019          --  Copy the table of interfaces of the parent
1020
1021          if not System."=" (Old_TSD_Ptr.Ifaces_Table_Ptr,
1022                             System.Null_Address)
1023          then
1024             Old_Iface_Table_Ptr :=
1025               To_Interface_Data_Ptr (Old_TSD_Ptr.Ifaces_Table_Ptr);
1026             New_Iface_Table_Ptr :=
1027               To_Interface_Data_Ptr (New_TSD_Ptr.Ifaces_Table_Ptr);
1028
1029             New_Iface_Table_Ptr.Table (1 .. Old_Iface_Table_Ptr.Nb_Ifaces) :=
1030               Old_Iface_Table_Ptr.Table (1 .. Old_Iface_Table_Ptr.Nb_Ifaces);
1031          end if;
1032
1033       else
1034          New_TSD_Ptr.Idepth := 0;
1035       end if;
1036
1037       New_TSD_Ptr.Tags_Table (0) := New_Tag;
1038    end Inherit_TSD;
1039
1040    -----------------------------
1041    -- Interface_Ancestor_Tags --
1042    -----------------------------
1043
1044    function Interface_Ancestor_Tags (T : Tag) return Tag_Array is
1045       Iface_Table : Interface_Data_Ptr;
1046
1047    begin
1048       Iface_Table := To_Interface_Data_Ptr (TSD (T).Ifaces_Table_Ptr);
1049
1050       if Iface_Table = null then
1051          declare
1052             Table : Tag_Array (1 .. 0);
1053          begin
1054             return Table;
1055          end;
1056       else
1057          declare
1058             Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces);
1059          begin
1060             for J in 1 .. Iface_Table.Nb_Ifaces loop
1061                Table (J) := Iface_Table.Table (J).Iface_Tag;
1062             end loop;
1063
1064             return Table;
1065          end;
1066       end if;
1067    end Interface_Ancestor_Tags;
1068
1069    ------------------
1070    -- Internal_Tag --
1071    ------------------
1072
1073    function Internal_Tag (External : String) return Tag is
1074       Ext_Copy : aliased String (External'First .. External'Last + 1);
1075       Res      : Tag;
1076
1077    begin
1078       --  Make a copy of the string representing the external tag with
1079       --  a null at the end.
1080
1081       Ext_Copy (External'Range) := External;
1082       Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
1083       Res := External_Tag_HTable.Get (Ext_Copy'Address);
1084
1085       if Res = null then
1086          declare
1087             Msg1 : constant String := "unknown tagged type: ";
1088             Msg2 : String (1 .. Msg1'Length + External'Length);
1089
1090          begin
1091             Msg2 (1 .. Msg1'Length) := Msg1;
1092             Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
1093               External;
1094             Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2);
1095          end;
1096       end if;
1097
1098       return Res;
1099    end Internal_Tag;
1100
1101    ---------------------------------
1102    -- Is_Descendant_At_Same_Level --
1103    ---------------------------------
1104
1105    function Is_Descendant_At_Same_Level
1106      (Descendant : Tag;
1107       Ancestor   : Tag) return Boolean
1108    is
1109    begin
1110       return CW_Membership (Descendant, Ancestor)
1111         and then TSD (Descendant).Access_Level = TSD (Ancestor).Access_Level;
1112    end Is_Descendant_At_Same_Level;
1113
1114    -------------------
1115    -- Is_Primary_DT --
1116    -------------------
1117
1118    function Is_Primary_DT (T : Tag) return Boolean is
1119       Signature  : constant Storage_Offset_Ptr :=
1120                      To_Storage_Offset_Ptr (To_Address (T) - K_Signature);
1121       Sig_Values : constant Signature_Values :=
1122                      To_Signature_Values (Signature.all);
1123    begin
1124       return Sig_Values (2) = Primary_DT;
1125    end Is_Primary_DT;
1126
1127    ------------
1128    -- Length --
1129    ------------
1130
1131    function Length (Str : Cstring_Ptr) return Natural is
1132       Len : Integer := 1;
1133
1134    begin
1135       while Str (Len) /= ASCII.Nul loop
1136          Len := Len + 1;
1137       end loop;
1138
1139       return Len - 1;
1140    end Length;
1141
1142    -------------------
1143    -- Offset_To_Top --
1144    -------------------
1145
1146    function Offset_To_Top
1147      (This : System.Address) return System.Storage_Elements.Storage_Offset
1148    is
1149       Curr_DT       : constant Tag := To_Tag_Ptr (This).all;
1150       Offset_To_Top : Storage_Offset_Ptr;
1151    begin
1152       Offset_To_Top := To_Storage_Offset_Ptr
1153                          (To_Address (Curr_DT) - K_Offset_To_Top);
1154
1155       if Offset_To_Top.all = SSE.Storage_Offset'Last then
1156          Offset_To_Top := To_Storage_Offset_Ptr (This + Tag_Size);
1157       end if;
1158
1159       return Offset_To_Top.all;
1160    end Offset_To_Top;
1161
1162    ---------
1163    -- OSD --
1164    ---------
1165
1166    function OSD (T : Tag) return Object_Specific_Data_Ptr is
1167       OSD_Ptr : constant Addr_Ptr :=
1168                   To_Addr_Ptr (To_Address (T) - K_Typeinfo);
1169    begin
1170       pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
1171       return To_Object_Specific_Data_Ptr (OSD_Ptr.all);
1172    end OSD;
1173
1174    -----------------
1175    -- Parent_Size --
1176    -----------------
1177
1178    function Parent_Size
1179      (Obj : System.Address;
1180       T   : Tag) return SSE.Storage_Count
1181    is
1182       Parent_Slot : constant Positive := 1;
1183       --  The tag of the parent is always in the first slot of the table of
1184       --  ancestor tags.
1185
1186       Size_Slot : constant Positive := 1;
1187       --  The pointer to the _size primitive is always in the first slot of
1188       --  the dispatch table.
1189
1190       Parent_Tag : Tag;
1191       --  The tag of the parent type through the dispatch table
1192
1193       F : Acc_Size;
1194       --  Access to the _size primitive of the parent
1195
1196    begin
1197       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1198       Parent_Tag := TSD (T).Tags_Table (Parent_Slot);
1199       F := To_Acc_Size (Predefined_DT (Parent_Tag).Prims_Ptr (Size_Slot));
1200
1201       --  Here we compute the size of the _parent field of the object
1202
1203       return SSE.Storage_Count (F.all (Obj));
1204    end Parent_Size;
1205
1206    ----------------
1207    -- Parent_Tag --
1208    ----------------
1209
1210    function Parent_Tag (T : Tag) return Tag is
1211    begin
1212       if T = No_Tag then
1213          raise Tag_Error;
1214       end if;
1215
1216       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1217
1218       --  The Parent_Tag of a root-level tagged type is defined to be No_Tag.
1219       --  The first entry in the Ancestors_Tags array will be null for such
1220       --  a type, but it's better to be explicit about returning No_Tag in
1221       --  this case.
1222
1223       if TSD (T).Idepth = 0 then
1224          return No_Tag;
1225       else
1226          return TSD (T).Tags_Table (1);
1227       end if;
1228    end Parent_Tag;
1229
1230    -------------------
1231    -- Predefined_DT --
1232    -------------------
1233
1234    function Predefined_DT (T : Tag) return Tag is
1235    begin
1236       return To_Tag (To_Address (T) - DT_Prologue_Size);
1237    end Predefined_DT;
1238
1239    ----------------------------
1240    -- Register_Interface_Tag --
1241    ----------------------------
1242
1243    procedure Register_Interface_Tag
1244      (T           : Tag;
1245       Interface_T : Tag;
1246       Position    : Positive)
1247    is
1248       New_T_TSD   : Type_Specific_Data_Ptr;
1249       Iface_Table : Interface_Data_Ptr;
1250
1251    begin
1252       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
1253       pragma Assert (Check_Signature (Interface_T, Must_Be_Interface));
1254
1255       New_T_TSD   := TSD (T);
1256       Iface_Table := To_Interface_Data_Ptr (New_T_TSD.Ifaces_Table_Ptr);
1257
1258       pragma Assert (Position <= Iface_Table.Nb_Ifaces);
1259       Iface_Table.Table (Position).Iface_Tag := Interface_T;
1260    end Register_Interface_Tag;
1261
1262    ------------------
1263    -- Register_Tag --
1264    ------------------
1265
1266    procedure Register_Tag (T : Tag) is
1267    begin
1268       External_Tag_HTable.Set (T);
1269    end Register_Tag;
1270
1271    ----------------------
1272    -- Set_Access_Level --
1273    ----------------------
1274
1275    procedure Set_Access_Level (T : Tag; Value : Natural) is
1276    begin
1277       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1278       TSD (T).Access_Level := Value;
1279    end Set_Access_Level;
1280
1281    ---------------------
1282    -- Set_Entry_Index --
1283    ---------------------
1284
1285    procedure Set_Entry_Index
1286      (T        : Tag;
1287       Position : Positive;
1288       Value    : Positive)
1289    is
1290    begin
1291       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1292       pragma Assert (Position <= Get_Num_Prim_Ops (T));
1293       SSD (T).SSD_Table (Position).Index := Value;
1294    end Set_Entry_Index;
1295
1296    -----------------------
1297    -- Set_Expanded_Name --
1298    -----------------------
1299
1300    procedure Set_Expanded_Name (T : Tag; Value : System.Address) is
1301    begin
1302       pragma Assert
1303         (Check_Signature (T, Must_Be_Primary_Or_Interface));
1304       TSD (T).Expanded_Name := To_Cstring_Ptr (Value);
1305    end Set_Expanded_Name;
1306
1307    ----------------------
1308    -- Set_External_Tag --
1309    ----------------------
1310
1311    procedure Set_External_Tag (T : Tag; Value : System.Address) is
1312    begin
1313       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
1314       TSD (T).External_Tag := To_Cstring_Ptr (Value);
1315    end Set_External_Tag;
1316
1317    -------------------------
1318    -- Set_Interface_Table --
1319    -------------------------
1320
1321    procedure Set_Interface_Table (T : Tag; Value : System.Address) is
1322    begin
1323       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
1324       TSD (T).Ifaces_Table_Ptr := Value;
1325    end Set_Interface_Table;
1326
1327    ----------------------
1328    -- Set_Num_Prim_Ops --
1329    ----------------------
1330
1331    procedure Set_Num_Prim_Ops (T : Tag; Value : Natural) is
1332    begin
1333       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
1334
1335       if Is_Primary_DT (T) then
1336          TSD (T).Num_Prim_Ops := Value;
1337       else
1338          OSD (T).Num_Prim_Ops := Value;
1339       end if;
1340    end Set_Num_Prim_Ops;
1341
1342    ----------------------
1343    -- Set_Offset_Index --
1344    ----------------------
1345
1346    procedure Set_Offset_Index
1347      (T        : Tag;
1348       Position : Positive;
1349       Value    : Positive)
1350    is
1351    begin
1352       pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
1353       pragma Assert (Position <= Get_Num_Prim_Ops (T));
1354       OSD (T).OSD_Table (Position) := Value;
1355    end Set_Offset_Index;
1356
1357    -----------------------
1358    -- Set_Offset_To_Top --
1359    -----------------------
1360
1361    procedure Set_Offset_To_Top
1362      (This          : System.Address;
1363       Interface_T   : Tag;
1364       Is_Static     : Boolean;
1365       Offset_Value  : System.Storage_Elements.Storage_Offset;
1366       Offset_Func   : System.Address)
1367    is
1368       Prim_DT       : Tag;
1369       Sec_Base      : System.Address;
1370       Sec_DT        : Tag;
1371       Offset_To_Top : Storage_Offset_Ptr;
1372       Iface_Table   : Interface_Data_Ptr;
1373       Obj_TSD       : Type_Specific_Data_Ptr;
1374    begin
1375       if System."=" (This, System.Null_Address) then
1376          pragma Assert
1377            (Check_Signature (Interface_T, Must_Be_Primary_DT));
1378          pragma Assert (Offset_Value = 0);
1379
1380          Offset_To_Top :=
1381            To_Storage_Offset_Ptr (To_Address (Interface_T) - K_Offset_To_Top);
1382          Offset_To_Top.all := Offset_Value;
1383          return;
1384       end if;
1385
1386       --  "This" points to the primary DT and we must save Offset_Value in the
1387       --  Offset_To_Top field of the corresponding secondary dispatch table.
1388
1389       Prim_DT  := To_Tag_Ptr (This).all;
1390
1391       pragma Assert
1392         (Check_Signature (Prim_DT, Must_Be_Primary_DT));
1393
1394       --  Save the offset to top field in the secondary dispatch table.
1395
1396       if Offset_Value /= 0 then
1397          Sec_Base := This + Offset_Value;
1398          Sec_DT   := To_Tag_Ptr (Sec_Base).all;
1399          Offset_To_Top :=
1400            To_Storage_Offset_Ptr (To_Address (Sec_DT) - K_Offset_To_Top);
1401
1402          pragma Assert
1403            (Check_Signature (Sec_DT, Must_Be_Secondary_DT));
1404
1405          if Is_Static then
1406             Offset_To_Top.all := Offset_Value;
1407          else
1408             Offset_To_Top.all := SSE.Storage_Offset'Last;
1409          end if;
1410       end if;
1411
1412       --  Save Offset_Value in the table of interfaces of the primary DT. This
1413       --  data will be used by the subprogram "Displace" to give support to
1414       --  backward abstract interface type conversions.
1415
1416       Obj_TSD     := TSD (Prim_DT);
1417       Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr);
1418
1419       --  Register the offset in the table of interfaces
1420
1421       if Iface_Table /= null then
1422          for Id in 1 .. Iface_Table.Nb_Ifaces loop
1423             if Iface_Table.Table (Id).Iface_Tag = Interface_T then
1424                Iface_Table.Table (Id).Static_Offset_To_Top := Is_Static;
1425
1426                if Is_Static then
1427                   Iface_Table.Table (Id).Offset_To_Top_Value := Offset_Value;
1428                else
1429                   Iface_Table.Table (Id).Offset_To_Top_Func := Offset_Func;
1430                end if;
1431
1432                return;
1433             end if;
1434          end loop;
1435       end if;
1436
1437       --  If we arrive here there is some error in the run-time data structure
1438
1439       raise Program_Error;
1440    end Set_Offset_To_Top;
1441
1442    -------------
1443    -- Set_OSD --
1444    -------------
1445
1446    procedure Set_OSD (T : Tag; Value : System.Address) is
1447       OSD_Ptr : constant Addr_Ptr :=
1448                   To_Addr_Ptr (To_Address (T) - K_Typeinfo);
1449    begin
1450       pragma Assert (Check_Signature (T, Must_Be_Secondary_DT));
1451       OSD_Ptr.all := Value;
1452    end Set_OSD;
1453
1454    ------------------------------------
1455    -- Set_Predefined_Prim_Op_Address --
1456    ------------------------------------
1457
1458    procedure Set_Predefined_Prim_Op_Address
1459      (T        : Tag;
1460       Position : Positive;
1461       Value    : System.Address)
1462    is
1463    begin
1464       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
1465       pragma Assert (Position >= 1 and then Position <= Default_Prim_Op_Count);
1466       Predefined_DT (T).Prims_Ptr (Position) := Value;
1467    end Set_Predefined_Prim_Op_Address;
1468
1469    -------------------------
1470    -- Set_Prim_Op_Address --
1471    -------------------------
1472
1473    procedure Set_Prim_Op_Address
1474      (T        : Tag;
1475       Position : Positive;
1476       Value    : System.Address)
1477    is
1478    begin
1479       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
1480       pragma Assert (Position <= Get_Num_Prim_Ops (T));
1481       T.Prims_Ptr (Position) := Value;
1482    end Set_Prim_Op_Address;
1483
1484    ----------------------
1485    -- Set_Prim_Op_Kind --
1486    ----------------------
1487
1488    procedure Set_Prim_Op_Kind
1489      (T        : Tag;
1490       Position : Positive;
1491       Value    : Prim_Op_Kind)
1492    is
1493    begin
1494       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1495       pragma Assert (Position <= Get_Num_Prim_Ops (T));
1496       SSD (T).SSD_Table (Position).Kind := Value;
1497    end Set_Prim_Op_Kind;
1498
1499    -------------------
1500    -- Set_RC_Offset --
1501    -------------------
1502
1503    procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is
1504    begin
1505       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1506       TSD (T).RC_Offset := Value;
1507    end Set_RC_Offset;
1508
1509    ---------------------------
1510    -- Set_Remotely_Callable --
1511    ---------------------------
1512
1513    procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is
1514    begin
1515       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1516       TSD (T).Remotely_Callable := Value;
1517    end Set_Remotely_Callable;
1518
1519    -------------------
1520    -- Set_Signature --
1521    -------------------
1522
1523    procedure Set_Signature (T : Tag; Value : Signature_Kind) is
1524       Signature : constant System.Address := To_Address (T) - K_Signature;
1525       Sig_Ptr   : constant Signature_Values_Ptr :=
1526                     To_Signature_Values_Ptr (Signature);
1527    begin
1528       Sig_Ptr.all (1) := Valid_Signature;
1529       Sig_Ptr.all (2) := Value;
1530    end Set_Signature;
1531
1532    -------------
1533    -- Set_SSD --
1534    -------------
1535
1536    procedure Set_SSD (T : Tag; Value : System.Address) is
1537    begin
1538       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1539       TSD (T).SSD_Ptr := Value;
1540    end Set_SSD;
1541
1542    ---------------------
1543    -- Set_Tagged_Kind --
1544    ---------------------
1545
1546    procedure Set_Tagged_Kind (T : Tag; Value : Tagged_Kind) is
1547       Tagged_Kind_Ptr : constant System.Address :=
1548                           To_Address (T) - K_Tagged_Kind;
1549    begin
1550       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
1551       To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all := Value;
1552    end Set_Tagged_Kind;
1553
1554    -------------
1555    -- Set_TSD --
1556    -------------
1557
1558    procedure Set_TSD (T : Tag; Value : System.Address) is
1559       TSD_Ptr : Addr_Ptr;
1560    begin
1561       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
1562       TSD_Ptr := To_Addr_Ptr (To_Address (T) - K_Typeinfo);
1563       TSD_Ptr.all := Value;
1564    end Set_TSD;
1565
1566    ---------
1567    -- SSD --
1568    ---------
1569
1570    function SSD (T : Tag) return Select_Specific_Data_Ptr is
1571    begin
1572       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1573       return To_Select_Specific_Data_Ptr (TSD (T).SSD_Ptr);
1574    end SSD;
1575
1576    ------------------
1577    -- Typeinfo_Ptr --
1578    ------------------
1579
1580    function Typeinfo_Ptr (T : Tag) return System.Address is
1581       TSD_Ptr : constant Addr_Ptr :=
1582                   To_Addr_Ptr (To_Address (T) - K_Typeinfo);
1583    begin
1584       return TSD_Ptr.all;
1585    end Typeinfo_Ptr;
1586
1587    ---------
1588    -- TSD --
1589    ---------
1590
1591    function TSD (T : Tag) return Type_Specific_Data_Ptr is
1592       TSD_Ptr : constant Addr_Ptr :=
1593                   To_Addr_Ptr (To_Address (T) - K_Typeinfo);
1594    begin
1595       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
1596       return To_Type_Specific_Data_Ptr (TSD_Ptr.all);
1597    end TSD;
1598
1599    ------------------------
1600    -- Wide_Expanded_Name --
1601    ------------------------
1602
1603    WC_Encoding : Character;
1604    pragma Import (C, WC_Encoding, "__gl_wc_encoding");
1605    --  Encoding method for source, as exported by binder
1606
1607    function Wide_Expanded_Name (T : Tag) return Wide_String is
1608    begin
1609       return String_To_Wide_String
1610         (Expanded_Name (T), Get_WC_Encoding_Method (WC_Encoding));
1611    end Wide_Expanded_Name;
1612
1613    -----------------------------
1614    -- Wide_Wide_Expanded_Name --
1615    -----------------------------
1616
1617    function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is
1618    begin
1619       return String_To_Wide_Wide_String
1620         (Expanded_Name (T), Get_WC_Encoding_Method (WC_Encoding));
1621    end Wide_Wide_Expanded_Name;
1622
1623 end Ada.Tags;