gcc/ada/a-tags.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                             A D A . T A G S                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Exceptions;
  35 with System.HTable;
  36 with System.Storage_Elements; use System.Storage_Elements;
  37
  38 pragma Elaborate_All (System.HTable);
  39
  40 package body Ada.Tags is
  41
  42 --  Structure of the GNAT Primary Dispatch Table
  43
  44 --           +-----------------------+
  45 --           |       Signature       |
  46 --           +-----------------------+
  47 --           |     Offset_To_Top     |
  48 --           +-----------------------+
  49 --           | Typeinfo_Ptr/TSD_Ptr  | ---> Type Specific Data
  50 --  Tag ---> +-----------------------+      +-------------------+
  51 --           |        table of       |      | inheritance depth |
  52 --           :     primitive ops     :      +-------------------+
  53 --           |        pointers       |      |   access level    |
  54 --           +-----------------------+      +-------------------+
  55 --                                          |   expanded name   |
  56 --                                          +-------------------+
  57 --                                          |   external tag    |
  58 --                                          +-------------------+
  59 --                                          |   hash table link |
  60 --                                          +-------------------+
  61 --                                          | remotely callable |
  62 --                                          +-------------------+
  63 --                                          | rec ctrler offset |
  64 --                                          +-------------------+
  65 --                                          |   num prim ops    |
  66 --                                          +-------------------+
  67 --                                          |  num interfaces   |
  68 --                                          +-------------------+
  69 --           Select Specific Data      <--- |     SSD_Ptr       |
  70 --           +-----------------------+      +-------------------+
  71 --           | table of primitive    |      | table of          |
  72 --           :    operation          :      :    ancestor       :
  73 --           |       kinds           |      |       tags        |
  74 --           +-----------------------+      +-------------------+
  75 --           | table of              |      | table of          |
  76 --           :    entry              :      :    interface      :
  77 --           |       indices         |      |       tags        |
  78 --           +-----------------------+      +-------------------+
  79
  80 --  Structure of the GNAT Secondary Dispatch Table
  81
  82 --           +-----------------------+
  83 --           |       Signature       |
  84 --           +-----------------------+
  85 --           |     Offset_To_Top     |
  86 --           +-----------------------+
  87 --           |        OSD_Ptr        |---> Object Specific Data
  88 --  Tag ---> +-----------------------+      +---------------+
  89 --           |        table of       |      | num prim ops  |
  90 --           :      primitive op     :      +---------------+
  91 --           |     thunk pointers    |      | table of      |
  92 --           +-----------------------+      +   primitive   |
  93 --                                          |    op offsets |
  94 --                                          +---------------+
  95
  96    Offset_To_Signature : constant SSE.Storage_Count :=
  97                            DT_Typeinfo_Ptr_Size
  98                              + DT_Offset_To_Top_Size
  99                              + DT_Signature_Size;
 100
 101    subtype Cstring is String (Positive);
 102    type Cstring_Ptr is access all Cstring;
 103
 104    --  We suppress index checks because the declared size in the record below
 105    --  is a dummy size of one (see below).
 106
 107    type Tag_Table is array (Natural range <>) of Tag;
 108    pragma Suppress_Initialization (Tag_Table);
 109    pragma Suppress (Index_Check, On => Tag_Table);
 110
 111    --  Object specific data types
 112
 113    type Object_Specific_Data_Array is array (Positive range <>) of Positive;
 114
 115    type Object_Specific_Data (Nb_Prim : Positive) is record
 116       Num_Prim_Ops : Natural;
 117       --  Number of primitive operations of the dispatch table. This field is
 118       --  used by the run-time check routines that are activated when the
 119       --  run-time is compiled with assertions enabled.
 120
 121       OSD_Table : Object_Specific_Data_Array (1 .. Nb_Prim);
 122       --  Table used in secondary DT to reference their counterpart in the
 123       --  select specific data (in the TSD of the primary DT). This construct
 124       --  is used in the handling of dispatching triggers in select statements.
 125       --  Nb_Prim is the number of non-predefined primitive operations.
 126    end record;
 127
 128    --  Select specific data types
 129
 130    type Select_Specific_Data_Element is record
 131       Index : Positive;
 132       Kind  : Prim_Op_Kind;
 133    end record;
 134
 135    type Select_Specific_Data_Array is
 136      array (Positive range <>) of Select_Specific_Data_Element;
 137
 138    type Select_Specific_Data (Nb_Prim : Positive) is record
 139       SSD_Table : Select_Specific_Data_Array (1 .. Nb_Prim);
 140       --  NOTE: Nb_Prim is the number of non-predefined primitive operations
 141    end record;
 142
 143    --  Type specific data types
 144
 145    type Type_Specific_Data is record
 146       Idepth : Natural;
 147       --  Inheritance Depth Level: Used to implement the membership test
 148       --  associated with single inheritance of tagged types in constant-time.
 149       --  In addition it also indicates the size of the first table stored in
 150       --  the Tags_Table component (see comment below).
 151
 152       Access_Level : Natural;
 153       --  Accessibility level required to give support to Ada 2005 nested type
 154       --  extensions. This feature allows safe nested type extensions by
 155       --  shifting the accessibility checks to certain operations, rather than
 156       --  being enforced at the type declaration. In particular, by performing
 157       --  run-time accessibility checks on class-wide allocators, class-wide
 158       --  function return, and class-wide stream I/O, the danger of objects
 159       --  outliving their type declaration can be eliminated (Ada 2005: AI-344)
 160
 161       Expanded_Name : Cstring_Ptr;
 162       External_Tag  : Cstring_Ptr;
 163       HT_Link       : Tag;
 164       --  Components used to give support to the Ada.Tags subprograms described
 165       --  in ARM 3.9
 166
 167       Remotely_Callable : Boolean;
 168       --  Used to check ARM E.4 (18)
 169
 170       RC_Offset : SSE.Storage_Offset;
 171       --  Controller Offset: Used to give support to tagged controlled objects
 172       --  (see Get_Deep_Controller at s-finimp)
 173
 174       Num_Prim_Ops : Natural;
 175       --  Number of primitive operations of the dispatch table. This field is
 176       --  used for additional run-time checks when the run-time is compiled
 177       --  with assertions enabled.
 178
 179       Num_Interfaces : Natural;
 180       --  Number of abstract interface types implemented by the tagged type.
 181       --  The value Idepth+Num_Interfaces indicates the end of the second table
 182       --  stored in the Tags_Table component. It is used to implement the
 183       --  membership test associated with interfaces (Ada 2005:AI-251).
 184
 185       SSD_Ptr : System.Address;
 186       --  Pointer to a table of records used in dispatching selects. This
 187       --  field has a meaningful value for all tagged types that implement
 188       --  a limited, protected, synchronized or task interfaces and have
 189       --  non-predefined primitive operations.
 190
 191       Tags_Table : Tag_Table (0 .. 1);
 192       --  The size of the Tags_Table array actually depends on the tagged type
 193       --  to which it applies. The compiler ensures that has enough space to
 194       --  store all the entries of the two tables phisically stored there: the
 195       --  "table of ancestor tags" and the "table of interface tags". For this
 196       --  purpose we are using the same mechanism as for the Prims_Ptr array in
 197       --  the Dispatch_Table record. See comments below on Prims_Ptr for
 198       --  further details.
 199    end record;
 200
 201    type Dispatch_Table is record
 202
 203       --  According to the C++ ABI the components Offset_To_Top and
 204       --  Typeinfo_Ptr are stored just "before" the dispatch table (that is,
 205       --  the Prims_Ptr table), and they are referenced with negative offsets
 206       --  referring to the base of the dispatch table. The _Tag (or the
 207       --  VTable_Ptr in C++ terminology) must point to the base of the virtual
 208       --  table, just after these components, to point to the Prims_Ptr table.
 209       --  For this purpose the expander generates a Prims_Ptr table that has
 210       --  enough space for these additional components, and generates code that
 211       --  displaces the _Tag to point after these components.
 212
 213       --  Offset_To_Top : Natural;
 214       --  Typeinfo_Ptr  : System.Address;
 215
 216       Prims_Ptr : Address_Array (1 .. 1);
 217       --  The size of the Prims_Ptr array actually depends on the tagged type
 218       --  to which it applies. For each tagged type, the expander computes the
 219       --  actual array size, allocates the Dispatch_Table record accordingly,
 220       --  and generates code that displaces the base of the record after the
 221       --  Typeinfo_Ptr component. For this reason the first two components have
 222       --  been commented in the previous declaration. The access to these
 223       --  components is done by means of local functions.
 224       --
 225       --  To avoid the use of discriminants to define the actual size of the
 226       --  dispatch table, we used to declare the tag as a pointer to a record
 227       --  that contains an arbitrary array of addresses, using Positive as its
 228       --  index. This ensures that there are never range checks when accessing
 229       --  the dispatch table, but it prevents GDB from displaying tagged types
 230       --  properly. A better approach is to declare this record type as holding
 231       --  small number of addresses, and to explicitly suppress checks on it.
 232       --
 233       --  Note that in both cases, this type is never allocated, and serves
 234       --  only to declare the corresponding access type.
 235    end record;
 236
 237    --  Run-time check types and subprograms: These subprograms are used only
 238    --  when the run-time is compiled with assertions enabled.
 239
 240    type Signature_Type is
 241       (Must_Be_Primary_DT,
 242        Must_Be_Secondary_DT,
 243        Must_Be_Primary_Or_Secondary_DT,
 244        Must_Be_Interface,
 245        Must_Be_Primary_Or_Interface);
 246    --  Type of signature accepted by primitives in this package that are called
 247    --  during the elaboration of tagged types. This type is used by the routine
 248    --  Check_Signature that is called only when the run-time is compiled with
 249    --  assertions enabled.
 250
 251    ---------------------------------------------
 252    -- Unchecked Conversions for String Fields --
 253    ---------------------------------------------
 254
 255    function To_Address is
 256      new Unchecked_Conversion (Cstring_Ptr, System.Address);
 257
 258    function To_Cstring_Ptr is
 259      new Unchecked_Conversion (System.Address, Cstring_Ptr);
 260
 261    ------------------------------------------------
 262    -- Unchecked Conversions for other components --
 263    ------------------------------------------------
 264
 265    type Acc_Size
 266      is access function (A : System.Address) return Long_Long_Integer;
 267
 268    function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size);
 269    --  The profile of the implicitly defined _size primitive
 270
 271    type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset;
 272
 273    function To_Storage_Offset_Ptr is
 274      new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
 275
 276    -----------------------
 277    -- Local Subprograms --
 278    -----------------------
 279
 280    function Check_Index
 281      (T     : Tag;
 282       Index : Natural) return Boolean;
 283    --  Check that Index references a valid entry of the dispatch table of T
 284
 285    function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean;
 286    --  Check that the signature of T is valid and corresponds with the subset
 287    --  specified by the signature Kind.
 288
 289    function Check_Size
 290      (Old_T       : Tag;
 291       New_T       : Tag;
 292       Entry_Count : Natural) return Boolean;
 293    --  Verify that Old_T and New_T have at least Entry_Count entries
 294
 295    function Get_Num_Prim_Ops (T : Tag) return Natural;
 296    --  Retrieve the number of primitive operations in the dispatch table of T
 297
 298    function Is_Primary_DT (T : Tag) return Boolean;
 299    pragma Inline_Always (Is_Primary_DT);
 300    --  Given a tag returns True if it has the signature of a primary dispatch
 301    --  table.  This is Inline_Always since it is called from other Inline_
 302    --  Always subprograms where we want no out of line code to be generated.
 303
 304    function Length (Str : Cstring_Ptr) return Natural;
 305    --  Length of string represented by the given pointer (treating the string
 306    --  as a C-style string, which is Nul terminated).
 307
 308    function Offset_To_Top
 309      (T : Tag) return System.Storage_Elements.Storage_Offset;
 310    --  Returns the current value of the offset_to_top component available in
 311    --  the prologue of the dispatch table.
 312
 313    function Typeinfo_Ptr (T : Tag) return System.Address;
 314    --  Returns the current value of the typeinfo_ptr component available in
 315    --  the prologue of the dispatch table.
 316
 317    pragma Unreferenced (Typeinfo_Ptr);
 318    --  These functions will be used for full compatibility with the C++ ABI
 319
 320    -------------------------
 321    -- External_Tag_HTable --
 322    -------------------------
 323
 324    type HTable_Headers is range 1 .. 64;
 325
 326    --  The following internal package defines the routines used for the
 327    --  instantiation of a new System.HTable.Static_HTable (see below). See
 328    --  spec in g-htable.ads for details of usage.
 329
 330    package HTable_Subprograms is
 331       procedure Set_HT_Link (T : Tag; Next : Tag);
 332       function  Get_HT_Link (T : Tag) return Tag;
 333       function Hash (F : System.Address) return HTable_Headers;
 334       function Equal (A, B : System.Address) return Boolean;
 335    end HTable_Subprograms;
 336
 337    package External_Tag_HTable is new System.HTable.Static_HTable (
 338      Header_Num => HTable_Headers,
 339      Element    => Dispatch_Table,
 340      Elmt_Ptr   => Tag,
 341      Null_Ptr   => null,
 342      Set_Next   => HTable_Subprograms.Set_HT_Link,
 343      Next       => HTable_Subprograms.Get_HT_Link,
 344      Key        => System.Address,
 345      Get_Key    => Get_External_Tag,
 346      Hash       => HTable_Subprograms.Hash,
 347      Equal      => HTable_Subprograms.Equal);
 348
 349    ------------------------
 350    -- HTable_Subprograms --
 351    ------------------------
 352
 353    --  Bodies of routines for hash table instantiation
 354
 355    package body HTable_Subprograms is
 356
 357       -----------
 358       -- Equal --
 359       -----------
 360
 361       function Equal (A, B : System.Address) return Boolean is
 362          Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
 363          Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
 364          J    : Integer := 1;
 365       begin
 366          loop
 367             if Str1 (J) /= Str2 (J) then
 368                return False;
 369             elsif Str1 (J) = ASCII.NUL then
 370                return True;
 371             else
 372                J := J + 1;
 373             end if;
 374          end loop;
 375       end Equal;
 376
 377       -----------------
 378       -- Get_HT_Link --
 379       -----------------
 380
 381       function Get_HT_Link (T : Tag) return Tag is
 382       begin
 383          return TSD (T).HT_Link;
 384       end Get_HT_Link;
 385
 386       ----------
 387       -- Hash --
 388       ----------
 389
 390       function Hash (F : System.Address) return HTable_Headers is
 391          function H is new System.HTable.Hash (HTable_Headers);
 392          Str : constant Cstring_Ptr    := To_Cstring_Ptr (F);
 393          Res : constant HTable_Headers := H (Str (1 .. Length (Str)));
 394       begin
 395          return Res;
 396       end Hash;
 397
 398       -----------------
 399       -- Set_HT_Link --
 400       -----------------
 401
 402       procedure Set_HT_Link (T : Tag; Next : Tag) is
 403       begin
 404          TSD (T).HT_Link := Next;
 405       end Set_HT_Link;
 406
 407    end HTable_Subprograms;
 408
 409    -----------------
 410    -- Check_Index --
 411    -----------------
 412
 413    function Check_Index
 414      (T     : Tag;
 415       Index : Natural) return Boolean
 416    is
 417       Max_Entries : constant Natural := Get_Num_Prim_Ops (T);
 418
 419    begin
 420       return Index /= 0 and then Index <= Max_Entries;
 421    end Check_Index;
 422
 423    ---------------------
 424    -- Check_Signature --
 425    ---------------------
 426
 427    function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean is
 428       Offset_To_Top_Ptr : constant Storage_Offset_Ptr :=
 429                             To_Storage_Offset_Ptr (To_Address (T)
 430                               - Offset_To_Signature);
 431
 432       Signature : constant Signature_Values :=
 433                     To_Signature_Values (Offset_To_Top_Ptr.all);
 434
 435       Signature_Id : Signature_Kind;
 436
 437    begin
 438       if Signature (1) /= Valid_Signature then
 439          Signature_Id := Unknown;
 440
 441       elsif Signature (2) in Primary_DT .. Abstract_Interface then
 442          Signature_Id := Signature (2);
 443
 444       else
 445          Signature_Id := Unknown;
 446       end if;
 447
 448       case Signature_Id is
 449          when Primary_DT         =>
 450             if Kind = Must_Be_Secondary_DT
 451               or else Kind = Must_Be_Interface
 452             then
 453                return False;
 454             end if;
 455
 456          when Secondary_DT       =>
 457             if Kind = Must_Be_Primary_DT
 458               or else Kind = Must_Be_Interface
 459             then
 460                return False;
 461             end if;
 462
 463          when Abstract_Interface =>
 464             if Kind = Must_Be_Primary_DT
 465               or else Kind = Must_Be_Secondary_DT
 466               or else Kind = Must_Be_Primary_Or_Secondary_DT
 467             then
 468                return False;
 469             end if;
 470
 471          when others =>
 472             return False;
 473
 474       end case;
 475
 476       return True;
 477    end Check_Signature;
 478
 479    ----------------
 480    -- Check_Size --
 481    ----------------
 482
 483    function Check_Size
 484      (Old_T       : Tag;
 485       New_T       : Tag;
 486       Entry_Count : Natural) return Boolean
 487    is
 488       Max_Entries_Old : constant Natural := Get_Num_Prim_Ops (Old_T);
 489       Max_Entries_New : constant Natural := Get_Num_Prim_Ops (New_T);
 490
 491    begin
 492       return Entry_Count <= Max_Entries_Old
 493         and then Entry_Count <= Max_Entries_New;
 494    end Check_Size;
 495
 496    -------------------
 497    -- CW_Membership --
 498    -------------------
 499
 500    --  Canonical implementation of Classwide Membership corresponding to:
 501
 502    --     Obj in Typ'Class
 503
 504    --  Each dispatch table contains a reference to a table of ancestors (stored
 505    --  in the first part of the Tags_Table) and a count of the level of
 506    --  inheritance "Idepth".
 507
 508    --  Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
 509    --  contained in the dispatch table referenced by Obj'Tag . Knowing the
 510    --  level of inheritance of both types, this can be computed in constant
 511    --  time by the formula:
 512
 513    --   Obj'tag.TSD.Ancestor_Tags (Obj'tag.TSD.Idepth - Typ'tag.TSD.Idepth)
 514    --     = Typ'tag
 515
 516    function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
 517       Pos : Integer;
 518    begin
 519       pragma Assert (Check_Signature (Obj_Tag, Must_Be_Primary_DT));
 520       pragma Assert (Check_Signature (Typ_Tag, Must_Be_Primary_DT));
 521       Pos := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
 522       return Pos >= 0 and then TSD (Obj_Tag).Tags_Table (Pos) = Typ_Tag;
 523    end CW_Membership;
 524
 525    -------------------
 526    -- IW_Membership --
 527    -------------------
 528
 529    --  Canonical implementation of Classwide Membership corresponding to:
 530
 531    --     Obj in Iface'Class
 532
 533    --  Each dispatch table contains a table with the tags of all the
 534    --  implemented interfaces.
 535
 536    --  Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
 537    --  that are contained in the dispatch table referenced by Obj'Tag.
 538
 539    function IW_Membership (This : System.Address; T : Tag) return Boolean is
 540       Curr_DT  : constant Tag := To_Tag_Ptr (This).all;
 541       Id       : Natural;
 542       Last_Id  : Natural;
 543       Obj_Base : System.Address;
 544       Obj_DT   : Tag;
 545       Obj_TSD  : Type_Specific_Data_Ptr;
 546
 547    begin
 548       pragma Assert
 549         (Check_Signature (Curr_DT, Must_Be_Primary_Or_Secondary_DT));
 550       pragma Assert
 551         (Check_Signature (T, Must_Be_Primary_Or_Interface));
 552
 553       Obj_Base := This - Offset_To_Top (Curr_DT);
 554       Obj_DT   := To_Tag_Ptr (Obj_Base).all;
 555
 556       pragma Assert
 557         (Check_Signature (Curr_DT, Must_Be_Primary_DT));
 558
 559       Obj_TSD := TSD (Obj_DT);
 560       Last_Id := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces;
 561
 562       if Obj_TSD.Num_Interfaces > 0 then
 563
 564          --  Traverse the ancestor tags table plus the interface tags table.
 565          --  The former part is required for:
 566
 567          --     Iface_CW in Typ'Class
 568
 569          Id := 0;
 570          loop
 571             if Obj_TSD.Tags_Table (Id) = T then
 572                return True;
 573             end if;
 574
 575             Id := Id + 1;
 576             exit when Id > Last_Id;
 577          end loop;
 578       end if;
 579
 580       return False;
 581    end IW_Membership;
 582
 583    --------------------
 584    -- Descendant_Tag --
 585    --------------------
 586
 587    function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
 588       Int_Tag : Tag;
 589
 590    begin
 591       pragma Assert (Check_Signature (Ancestor, Must_Be_Primary_DT));
 592       Int_Tag := Internal_Tag (External);
 593       pragma Assert (Check_Signature (Int_Tag, Must_Be_Primary_DT));
 594
 595       if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
 596          raise Tag_Error;
 597       end if;
 598
 599       return Int_Tag;
 600    end Descendant_Tag;
 601
 602    -------------------
 603    -- Expanded_Name --
 604    -------------------
 605
 606    function Expanded_Name (T : Tag) return String is
 607       Result : Cstring_Ptr;
 608
 609    begin
 610       if T = No_Tag then
 611          raise Tag_Error;
 612       end if;
 613
 614       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
 615       Result := TSD (T).Expanded_Name;
 616       return Result (1 .. Length (Result));
 617    end Expanded_Name;
 618
 619    ------------------
 620    -- External_Tag --
 621    ------------------
 622
 623    function External_Tag (T : Tag) return String is
 624       Result : Cstring_Ptr;
 625
 626    begin
 627       if T = No_Tag then
 628          raise Tag_Error;
 629       end if;
 630
 631       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
 632       Result := TSD (T).External_Tag;
 633
 634       return Result (1 .. Length (Result));
 635    end External_Tag;
 636
 637    ----------------------
 638    -- Get_Access_Level --
 639    ----------------------
 640
 641    function Get_Access_Level (T : Tag) return Natural is
 642    begin
 643       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 644       return TSD (T).Access_Level;
 645    end Get_Access_Level;
 646
 647    ---------------------
 648    -- Get_Entry_Index --
 649    ---------------------
 650
 651    function Get_Entry_Index (T : Tag; Position : Positive) return Positive is
 652       Index : constant Integer := Position - Default_Prim_Op_Count;
 653    begin
 654       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 655       pragma Assert (Index > 0);
 656       return SSD (T).SSD_Table (Index).Index;
 657    end Get_Entry_Index;
 658
 659    ----------------------
 660    -- Get_External_Tag --
 661    ----------------------
 662
 663    function Get_External_Tag (T : Tag) return System.Address is
 664    begin
 665       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 666       return To_Address (TSD (T).External_Tag);
 667    end Get_External_Tag;
 668
 669    ----------------------
 670    -- Get_Num_Prim_Ops --
 671    ----------------------
 672
 673    function Get_Num_Prim_Ops (T : Tag) return Natural is
 674    begin
 675       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
 676
 677       if Is_Primary_DT (T) then
 678          return TSD (T).Num_Prim_Ops;
 679       else
 680          return OSD (Interface_Tag (T)).Num_Prim_Ops;
 681       end if;
 682    end Get_Num_Prim_Ops;
 683
 684    -------------------------
 685    -- Get_Prim_Op_Address --
 686    -------------------------
 687
 688    function Get_Prim_Op_Address
 689      (T        : Tag;
 690       Position : Positive) return System.Address
 691    is
 692    begin
 693       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
 694       pragma Assert (Check_Index (T, Position));
 695       return T.Prims_Ptr (Position);
 696    end Get_Prim_Op_Address;
 697
 698    ----------------------
 699    -- Get_Prim_Op_Kind --
 700    ----------------------
 701
 702    function Get_Prim_Op_Kind
 703      (T        : Tag;
 704       Position : Positive) return Prim_Op_Kind
 705    is
 706       Index : constant Integer := Position - Default_Prim_Op_Count;
 707    begin
 708       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 709       pragma Assert (Index > 0);
 710       return SSD (T).SSD_Table (Index).Kind;
 711    end Get_Prim_Op_Kind;
 712
 713    ----------------------
 714    -- Get_Offset_Index --
 715    ----------------------
 716
 717    function Get_Offset_Index
 718      (T        : Interface_Tag;
 719       Position : Positive) return Positive
 720    is
 721       Index : constant Integer := Position - Default_Prim_Op_Count;
 722    begin
 723       pragma Assert (Check_Signature (Tag (T), Must_Be_Secondary_DT));
 724       pragma Assert (Index > 0);
 725       return OSD (T).OSD_Table (Index);
 726    end Get_Offset_Index;
 727
 728    -------------------
 729    -- Get_RC_Offset --
 730    -------------------
 731
 732    function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is
 733    begin
 734       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 735       return TSD (T).RC_Offset;
 736    end Get_RC_Offset;
 737
 738    ---------------------------
 739    -- Get_Remotely_Callable --
 740    ---------------------------
 741
 742    function Get_Remotely_Callable (T : Tag) return Boolean is
 743    begin
 744       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 745       return TSD (T).Remotely_Callable;
 746    end Get_Remotely_Callable;
 747
 748    ----------------
 749    -- Inherit_DT --
 750    ----------------
 751
 752    procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural) is
 753    begin
 754       pragma Assert (Check_Signature (Old_T, Must_Be_Primary_Or_Secondary_DT));
 755       pragma Assert (Check_Signature (New_T, Must_Be_Primary_Or_Secondary_DT));
 756       pragma Assert (Check_Size (Old_T, New_T, Entry_Count));
 757
 758       if Old_T /= null then
 759          New_T.Prims_Ptr (1 .. Entry_Count) :=
 760            Old_T.Prims_Ptr (1 .. Entry_Count);
 761       end if;
 762    end Inherit_DT;
 763
 764    -----------------
 765    -- Inherit_TSD --
 766    -----------------
 767
 768    procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag) is
 769       New_TSD_Ptr : Type_Specific_Data_Ptr;
 770       Old_TSD_Ptr : Type_Specific_Data_Ptr;
 771
 772    begin
 773       pragma Assert (Check_Signature (New_Tag, Must_Be_Primary_Or_Interface));
 774       New_TSD_Ptr := TSD (New_Tag);
 775
 776       if Old_Tag /= null then
 777          pragma Assert
 778            (Check_Signature (Old_Tag, Must_Be_Primary_Or_Interface));
 779          Old_TSD_Ptr := TSD (Old_Tag);
 780          New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1;
 781          New_TSD_Ptr.Num_Interfaces := Old_TSD_Ptr.Num_Interfaces;
 782
 783          --  Copy the "table of ancestor tags" plus the "table of interfaces"
 784          --  of the parent.
 785
 786          New_TSD_Ptr.Tags_Table
 787            (1 .. New_TSD_Ptr.Idepth + New_TSD_Ptr.Num_Interfaces) :=
 788              Old_TSD_Ptr.Tags_Table
 789                (0 .. Old_TSD_Ptr.Idepth + Old_TSD_Ptr.Num_Interfaces);
 790       else
 791          New_TSD_Ptr.Idepth         := 0;
 792          New_TSD_Ptr.Num_Interfaces := 0;
 793       end if;
 794
 795       New_TSD_Ptr.Tags_Table (0) := New_Tag;
 796    end Inherit_TSD;
 797
 798    ------------------
 799    -- Internal_Tag --
 800    ------------------
 801
 802    function Internal_Tag (External : String) return Tag is
 803       Ext_Copy : aliased String (External'First .. External'Last + 1);
 804       Res      : Tag;
 805
 806    begin
 807       --  Make a copy of the string representing the external tag with
 808       --  a null at the end.
 809
 810       Ext_Copy (External'Range) := External;
 811       Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
 812       Res := External_Tag_HTable.Get (Ext_Copy'Address);
 813
 814       if Res = null then
 815          declare
 816             Msg1 : constant String := "unknown tagged type: ";
 817             Msg2 : String (1 .. Msg1'Length + External'Length);
 818
 819          begin
 820             Msg2 (1 .. Msg1'Length) := Msg1;
 821             Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
 822               External;
 823             Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2);
 824          end;
 825       end if;
 826
 827       return Res;
 828    end Internal_Tag;
 829
 830    ---------------------------------
 831    -- Is_Descendant_At_Same_Level --
 832    ---------------------------------
 833
 834    function Is_Descendant_At_Same_Level
 835      (Descendant : Tag;
 836       Ancestor   : Tag) return Boolean
 837    is
 838    begin
 839       return CW_Membership (Descendant, Ancestor)
 840         and then TSD (Descendant).Access_Level = TSD (Ancestor).Access_Level;
 841    end Is_Descendant_At_Same_Level;
 842
 843    -------------------
 844    -- Is_Primary_DT --
 845    -------------------
 846
 847    function Is_Primary_DT (T : Tag) return Boolean is
 848       Offset_To_Top_Ptr : constant Storage_Offset_Ptr :=
 849                             To_Storage_Offset_Ptr (To_Address (T)
 850                               - Offset_To_Signature);
 851       Signature         : constant Signature_Values :=
 852                             To_Signature_Values (Offset_To_Top_Ptr.all);
 853    begin
 854       return Signature (2) = Primary_DT;
 855    end Is_Primary_DT;
 856
 857    ------------
 858    -- Length --
 859    ------------
 860
 861    function Length (Str : Cstring_Ptr) return Natural is
 862       Len : Integer := 1;
 863
 864    begin
 865       while Str (Len) /= ASCII.Nul loop
 866          Len := Len + 1;
 867       end loop;
 868
 869       return Len - 1;
 870    end Length;
 871
 872    -------------------
 873    -- Offset_To_Top --
 874    -------------------
 875
 876    function Offset_To_Top
 877      (T : Tag) return System.Storage_Elements.Storage_Offset
 878    is
 879       Offset_To_Top_Ptr : constant Storage_Offset_Ptr :=
 880                             To_Storage_Offset_Ptr (To_Address (T)
 881                               - DT_Typeinfo_Ptr_Size
 882                               - DT_Offset_To_Top_Size);
 883
 884    begin
 885       return Offset_To_Top_Ptr.all;
 886    end Offset_To_Top;
 887
 888    ---------
 889    -- OSD --
 890    ---------
 891
 892    function OSD
 893      (T : Interface_Tag) return Object_Specific_Data_Ptr
 894    is
 895       OSD_Ptr : Addr_Ptr;
 896
 897    begin
 898       OSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 899       return To_Object_Specific_Data_Ptr (OSD_Ptr.all);
 900    end OSD;
 901
 902    -----------------
 903    -- Parent_Size --
 904    -----------------
 905
 906    function Parent_Size
 907      (Obj : System.Address;
 908       T   : Tag) return SSE.Storage_Count
 909    is
 910       Parent_Tag : Tag;
 911       --  The tag of the parent type through the dispatch table
 912
 913       F : Acc_Size;
 914       --  Access to the _size primitive of the parent. We assume that it is
 915       --  always in the first slot of the dispatch table.
 916
 917    begin
 918       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 919       Parent_Tag := TSD (T).Tags_Table (1);
 920       F := To_Acc_Size (Parent_Tag.Prims_Ptr (1));
 921
 922       --  Here we compute the size of the _parent field of the object
 923
 924       return SSE.Storage_Count (F.all (Obj));
 925    end Parent_Size;
 926
 927    ----------------
 928    -- Parent_Tag --
 929    ----------------
 930
 931    function Parent_Tag (T : Tag) return Tag is
 932    begin
 933       if T = No_Tag then
 934          raise Tag_Error;
 935       end if;
 936
 937       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 938
 939       --  The Parent_Tag of a root-level tagged type is defined to be No_Tag.
 940       --  The first entry in the Ancestors_Tags array will be null for such
 941       --  a type, but it's better to be explicit about returning No_Tag in
 942       --  this case.
 943
 944       if TSD (T).Idepth = 0 then
 945          return No_Tag;
 946       else
 947          return TSD (T).Tags_Table (1);
 948       end if;
 949    end Parent_Tag;
 950
 951    ----------------------------
 952    -- Register_Interface_Tag --
 953    ----------------------------
 954
 955    procedure Register_Interface_Tag (T : Tag; Interface_T : Tag) is
 956       New_T_TSD : Type_Specific_Data_Ptr;
 957       Index     : Natural;
 958
 959    begin
 960       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
 961       pragma Assert (Check_Signature (Interface_T, Must_Be_Interface));
 962
 963       New_T_TSD := TSD (T);
 964
 965       --  Check if the interface is already registered
 966
 967       if New_T_TSD.Num_Interfaces > 0 then
 968          declare
 969             Id      : Natural          := New_T_TSD.Idepth + 1;
 970             Last_Id : constant Natural := New_T_TSD.Idepth
 971                                             + New_T_TSD.Num_Interfaces;
 972
 973          begin
 974             loop
 975                if New_T_TSD.Tags_Table (Id) = Interface_T then
 976                   return;
 977                end if;
 978
 979                Id := Id + 1;
 980                exit when Id > Last_Id;
 981             end loop;
 982          end;
 983       end if;
 984
 985       New_T_TSD.Num_Interfaces := New_T_TSD.Num_Interfaces + 1;
 986       Index := New_T_TSD.Idepth + New_T_TSD.Num_Interfaces;
 987       New_T_TSD.Tags_Table (Index) := Interface_T;
 988    end Register_Interface_Tag;
 989
 990    ------------------
 991    -- Register_Tag --
 992    ------------------
 993
 994    procedure Register_Tag (T : Tag) is
 995    begin
 996       External_Tag_HTable.Set (T);
 997    end Register_Tag;
 998
 999    ----------------------
1000    -- Set_Access_Level --
1001    ----------------------
1002
1003    procedure Set_Access_Level (T : Tag; Value : Natural) is
1004    begin
1005       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1006       TSD (T).Access_Level := Value;
1007    end Set_Access_Level;
1008
1009    ---------------------
1010    -- Set_Entry_Index --
1011    ---------------------
1012
1013    procedure Set_Entry_Index
1014      (T        : Tag;
1015       Position : Positive;
1016       Value    : Positive)
1017    is
1018       Index : constant Integer := Position - Default_Prim_Op_Count;
1019
1020    begin
1021       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1022       pragma Assert (Index > 0);
1023       SSD (T).SSD_Table (Index).Index := Value;
1024    end Set_Entry_Index;
1025
1026    -----------------------
1027    -- Set_Expanded_Name --
1028    -----------------------
1029
1030    procedure Set_Expanded_Name (T : Tag; Value : System.Address) is
1031    begin
1032       pragma Assert
1033         (Check_Signature (T, Must_Be_Primary_Or_Interface));
1034       TSD (T).Expanded_Name := To_Cstring_Ptr (Value);
1035    end Set_Expanded_Name;
1036
1037    ----------------------
1038    -- Set_External_Tag --
1039    ----------------------
1040
1041    procedure Set_External_Tag (T : Tag; Value : System.Address) is
1042    begin
1043       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
1044       TSD (T).External_Tag := To_Cstring_Ptr (Value);
1045    end Set_External_Tag;
1046
1047    ----------------------
1048    -- Set_Num_Prim_Ops --
1049    ----------------------
1050
1051    procedure Set_Num_Prim_Ops (T : Tag; Value : Natural) is
1052    begin
1053       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
1054
1055       if Is_Primary_DT (T) then
1056          TSD (T).Num_Prim_Ops := Value;
1057       else
1058          OSD (Interface_Tag (T)).Num_Prim_Ops := Value;
1059       end if;
1060    end Set_Num_Prim_Ops;
1061
1062    ----------------------
1063    -- Set_Offset_Index --
1064    ----------------------
1065
1066    procedure Set_Offset_Index
1067      (T        : Interface_Tag;
1068       Position : Positive;
1069       Value    : Positive)
1070    is
1071       Index : constant Integer := Position - Default_Prim_Op_Count;
1072    begin
1073       pragma Assert (Check_Signature (Tag (T), Must_Be_Secondary_DT));
1074       pragma Assert (Index > 0);
1075       OSD (T).OSD_Table (Index) := Value;
1076    end Set_Offset_Index;
1077
1078    -----------------------
1079    -- Set_Offset_To_Top --
1080    -----------------------
1081
1082    procedure Set_Offset_To_Top
1083      (T     : Tag;
1084       Value : System.Storage_Elements.Storage_Offset)
1085    is
1086       Offset_To_Top_Ptr : constant Storage_Offset_Ptr :=
1087                             To_Storage_Offset_Ptr (To_Address (T)
1088                               - DT_Typeinfo_Ptr_Size
1089                               - DT_Offset_To_Top_Size);
1090    begin
1091       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
1092       Offset_To_Top_Ptr.all := Value;
1093    end Set_Offset_To_Top;
1094
1095    -------------
1096    -- Set_OSD --
1097    -------------
1098
1099    procedure Set_OSD (T : Interface_Tag; Value : System.Address) is
1100       OSD_Ptr : Addr_Ptr;
1101    begin
1102       pragma Assert (Check_Signature (Tag (T), Must_Be_Secondary_DT));
1103       OSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
1104       OSD_Ptr.all := Value;
1105    end Set_OSD;
1106
1107    -------------------------
1108    -- Set_Prim_Op_Address --
1109    -------------------------
1110
1111    procedure Set_Prim_Op_Address
1112      (T        : Tag;
1113       Position : Positive;
1114       Value    : System.Address)
1115    is
1116    begin
1117       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
1118       pragma Assert (Check_Index (T, Position));
1119       T.Prims_Ptr (Position) := Value;
1120    end Set_Prim_Op_Address;
1121
1122    ----------------------
1123    -- Set_Prim_Op_Kind --
1124    ----------------------
1125
1126    procedure Set_Prim_Op_Kind
1127      (T        : Tag;
1128       Position : Positive;
1129       Value    : Prim_Op_Kind)
1130    is
1131       Index : constant Integer := Position - Default_Prim_Op_Count;
1132    begin
1133       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1134       pragma Assert (Index > 0);
1135       SSD (T).SSD_Table (Index).Kind := Value;
1136    end Set_Prim_Op_Kind;
1137
1138    -------------------
1139    -- Set_RC_Offset --
1140    -------------------
1141
1142    procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is
1143    begin
1144       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1145       TSD (T).RC_Offset := Value;
1146    end Set_RC_Offset;
1147
1148    ---------------------------
1149    -- Set_Remotely_Callable --
1150    ---------------------------
1151
1152    procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is
1153    begin
1154       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1155       TSD (T).Remotely_Callable := Value;
1156    end Set_Remotely_Callable;
1157
1158    -------------
1159    -- Set_SSD --
1160    -------------
1161
1162    procedure Set_SSD (T : Tag; Value : System.Address) is
1163    begin
1164       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
1165       TSD (T).SSD_Ptr := Value;
1166    end Set_SSD;
1167
1168    -------------
1169    -- Set_TSD --
1170    -------------
1171
1172    procedure Set_TSD (T : Tag; Value : System.Address) is
1173       TSD_Ptr : Addr_Ptr;
1174    begin
1175       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
1176       TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
1177       TSD_Ptr.all := Value;
1178    end Set_TSD;
1179
1180    ---------
1181    -- SSD --
1182    ---------
1183
1184    function SSD (T : Tag) return Select_Specific_Data_Ptr is
1185    begin
1186       return To_Select_Specific_Data_Ptr (TSD (T).SSD_Ptr);
1187    end SSD;
1188
1189    ------------------
1190    -- Typeinfo_Ptr --
1191    ------------------
1192
1193    function Typeinfo_Ptr (T : Tag) return System.Address is
1194       TSD_Ptr : constant Addr_Ptr :=
1195                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
1196    begin
1197       return TSD_Ptr.all;
1198    end Typeinfo_Ptr;
1199
1200    ---------
1201    -- TSD --
1202    ---------
1203
1204    function TSD (T : Tag) return Type_Specific_Data_Ptr is
1205       TSD_Ptr : constant Addr_Ptr :=
1206                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
1207    begin
1208       return To_Type_Specific_Data_Ptr (TSD_Ptr.all);
1209    end TSD;
1210
1211 end Ada.Tags;