gcc/ada/a-tags.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME COMPONENTS                          --
   4 --                                                                          --
   5 --                             A D A . T A G S                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2004 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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
  36 with System.HTable;
  37
  38 with Unchecked_Conversion;
  39
  40 pragma Elaborate_All (System.HTable);
  41
  42 package body Ada.Tags is
  43
  44 --  Structure of the GNAT Dispatch Table
  45
  46 --   +----------------------+
  47 --   |      TSD pointer  ---|-----> Type Specific Data
  48 --   +----------------------+       +-------------------+
  49 --   | table of             |       | inheritance depth |
  50 --   :   primitive ops      :       +-------------------+
  51 --   |     pointers         |       |   expanded name   |
  52 --   +----------------------+       +-------------------+
  53 --                                  |   external tag    |
  54 --                                  +-------------------+
  55 --                                  |   Hash table link |
  56 --                                  +-------------------+
  57 --                                  | Remotely Callable |
  58 --                                  +-------------------+
  59 --                                  | Rec Ctrler offset |
  60 --                                  +-------------------+
  61 --                                  | table of          |
  62 --                                  :   ancestor        :
  63 --                                  |      tags         |
  64 --                                  +-------------------+
  65
  66    subtype Cstring is String (Positive);
  67    type Cstring_Ptr is access all Cstring;
  68
  69    type Tag_Table is array (Natural range <>) of Tag;
  70    pragma Suppress_Initialization (Tag_Table);
  71    pragma Suppress (Index_Check, On => Tag_Table);
  72    --  We suppress index checks because the declared size in the record
  73    --  below is a dummy size of one (see below).
  74
  75    type Wide_Boolean is new Boolean;
  76    --  This name should probably be changed sometime ??? and indeed
  77    --  probably this field could simply be of type Standard.Boolean.
  78
  79    type Type_Specific_Data is record
  80       Idepth             : Natural;
  81       Expanded_Name      : Cstring_Ptr;
  82       External_Tag       : Cstring_Ptr;
  83       HT_Link            : Tag;
  84       Remotely_Callable  : Wide_Boolean;
  85       RC_Offset          : SSE.Storage_Offset;
  86       Ancestor_Tags      : Tag_Table (0 .. 1);
  87    end record;
  88    --  The size of the Ancestor_Tags array actually depends on the tagged
  89    --  type to which it applies.  We are using the same mechanism as for
  90    --  the Prims_Ptr array in the Dispatch_Table record.  See comments
  91    --  below for more details.
  92
  93    type Dispatch_Table is record
  94       TSD       : Type_Specific_Data_Ptr;
  95       Prims_Ptr : Address_Array (1 .. 1);
  96    end record;
  97    --  The size of the Prims_Ptr array actually depends on the tagged
  98    --  type to which it applies. For each tagged type, the expander
  99    --  computes the actual array size, and allocates the Dispatch_Table
 100    --  record accordingly.
 101    --
 102    --  To avoid the use of discriminants to define the actual size
 103    --  of the dispatch table, we used to declare the tag as a pointer
 104    --  to a record that contains an arbitrary array of addresses, using
 105    --  Positive as its index. This ensures that there are never range
 106    --  checks when accessing the dispatch table, but it prevents GDB
 107    --  from displaying tagged types properly. A better approach is
 108    --  to declare this record type as holding a small number of addresses,
 109    --  and to explicitly suppress checks on it.
 110    --
 111    --  Note that in both cases, this type is never allocated, and serves
 112    --  only to declare the corresponding access type.
 113
 114    ---------------------------------------------
 115    -- Unchecked Conversions for String Fields --
 116    ---------------------------------------------
 117
 118    function To_Cstring_Ptr is
 119      new Unchecked_Conversion (System.Address, Cstring_Ptr);
 120
 121    function To_Address is
 122      new Unchecked_Conversion (Cstring_Ptr, System.Address);
 123
 124    -----------------------
 125    -- Local Subprograms --
 126    -----------------------
 127
 128    function Length (Str : Cstring_Ptr) return Natural;
 129    --  Length of string represented by the given pointer (treating the
 130    --  string as a C-style string, which is Nul terminated).
 131
 132    -------------------------
 133    -- External_Tag_HTable --
 134    -------------------------
 135
 136    type HTable_Headers is range 1 .. 64;
 137
 138    --  The following internal package defines the routines used for
 139    --  the instantiation of a new System.HTable.Static_HTable (see
 140    --  below). See spec in g-htable.ads for details of usage.
 141
 142    package HTable_Subprograms is
 143       procedure Set_HT_Link (T : Tag; Next : Tag);
 144       function  Get_HT_Link (T : Tag) return Tag;
 145       function Hash (F : System.Address) return HTable_Headers;
 146       function Equal (A, B : System.Address) return Boolean;
 147    end HTable_Subprograms;
 148
 149    package External_Tag_HTable is new System.HTable.Static_HTable (
 150      Header_Num => HTable_Headers,
 151      Element    => Dispatch_Table,
 152      Elmt_Ptr   => Tag,
 153      Null_Ptr   => null,
 154      Set_Next   => HTable_Subprograms.Set_HT_Link,
 155      Next       => HTable_Subprograms.Get_HT_Link,
 156      Key        => System.Address,
 157      Get_Key    => Get_External_Tag,
 158      Hash       => HTable_Subprograms.Hash,
 159      Equal      => HTable_Subprograms.Equal);
 160
 161    ------------------------
 162    -- HTable_Subprograms --
 163    ------------------------
 164
 165    --  Bodies of routines for hash table instantiation
 166
 167    package body HTable_Subprograms is
 168
 169    -----------
 170    -- Equal --
 171    -----------
 172
 173       function Equal (A, B : System.Address) return Boolean is
 174          Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
 175          Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
 176          J    : Integer := 1;
 177
 178       begin
 179          loop
 180             if Str1 (J) /= Str2 (J) then
 181                return False;
 182
 183             elsif Str1 (J) = ASCII.NUL then
 184                return True;
 185
 186             else
 187                J := J + 1;
 188             end if;
 189          end loop;
 190       end Equal;
 191
 192       -----------------
 193       -- Get_HT_Link --
 194       -----------------
 195
 196       function Get_HT_Link (T : Tag) return Tag is
 197       begin
 198          return T.TSD.HT_Link;
 199       end Get_HT_Link;
 200
 201       ----------
 202       -- Hash --
 203       ----------
 204
 205       function Hash (F : System.Address) return HTable_Headers is
 206          function H is new System.HTable.Hash (HTable_Headers);
 207          Str : constant Cstring_Ptr    := To_Cstring_Ptr (F);
 208          Res : constant HTable_Headers := H (Str (1 .. Length (Str)));
 209       begin
 210          return Res;
 211       end Hash;
 212
 213       -----------------
 214       -- Set_HT_Link --
 215       -----------------
 216
 217       procedure Set_HT_Link (T : Tag; Next : Tag) is
 218       begin
 219          T.TSD.HT_Link := Next;
 220       end Set_HT_Link;
 221
 222    end HTable_Subprograms;
 223
 224    -------------------
 225    -- CW_Membership --
 226    -------------------
 227
 228    --  Canonical implementation of Classwide Membership corresponding to:
 229
 230    --     Obj in Typ'Class
 231
 232    --  Each dispatch table contains a reference to a table of ancestors
 233    --  (Ancestor_Tags) and a count of the level of inheritance "Idepth" .
 234
 235    --  Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
 236    --  contained in the dispatch table referenced by Obj'Tag . Knowing the
 237    --  level of inheritance of both types, this can be computed in constant
 238    --  time by the formula:
 239
 240    --   Obj'tag.TSD.Ancestor_Tags (Obj'tag.TSD.Idepth - Typ'tag.TSD.Idepth)
 241    --     = Typ'tag
 242
 243    function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
 244       Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth;
 245    begin
 246       return Pos >= 0 and then Obj_Tag.TSD.Ancestor_Tags (Pos) = Typ_Tag;
 247    end CW_Membership;
 248
 249    -------------------
 250    -- Expanded_Name --
 251    -------------------
 252
 253    function Expanded_Name (T : Tag) return String is
 254       Result : constant Cstring_Ptr := T.TSD.Expanded_Name;
 255    begin
 256       return Result (1 .. Length (Result));
 257    end Expanded_Name;
 258
 259    ------------------
 260    -- External_Tag --
 261    ------------------
 262
 263    function External_Tag (T : Tag) return String is
 264       Result : constant Cstring_Ptr := T.TSD.External_Tag;
 265    begin
 266       return Result (1 .. Length (Result));
 267    end External_Tag;
 268
 269    -----------------------
 270    -- Get_Expanded_Name --
 271    -----------------------
 272
 273    function Get_Expanded_Name (T : Tag) return System.Address is
 274    begin
 275       return To_Address (T.TSD.Expanded_Name);
 276    end Get_Expanded_Name;
 277
 278    ----------------------
 279    -- Get_External_Tag --
 280    ----------------------
 281
 282    function Get_External_Tag (T : Tag) return System.Address is
 283    begin
 284       return To_Address (T.TSD.External_Tag);
 285    end Get_External_Tag;
 286
 287    ---------------------------
 288    -- Get_Inheritance_Depth --
 289    ---------------------------
 290
 291    function Get_Inheritance_Depth (T : Tag) return Natural is
 292    begin
 293       return T.TSD.Idepth;
 294    end Get_Inheritance_Depth;
 295
 296    -------------------------
 297    -- Get_Prim_Op_Address --
 298    -------------------------
 299
 300    function Get_Prim_Op_Address
 301      (T        : Tag;
 302       Position : Positive) return System.Address
 303    is
 304    begin
 305       return T.Prims_Ptr (Position);
 306    end Get_Prim_Op_Address;
 307
 308    -------------------
 309    -- Get_RC_Offset --
 310    -------------------
 311
 312    function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is
 313    begin
 314       return T.TSD.RC_Offset;
 315    end Get_RC_Offset;
 316
 317    ---------------------------
 318    -- Get_Remotely_Callable --
 319    ---------------------------
 320
 321    function Get_Remotely_Callable (T : Tag) return Boolean is
 322    begin
 323       return T.TSD.Remotely_Callable = True;
 324    end Get_Remotely_Callable;
 325
 326    -------------
 327    -- Get_TSD --
 328    -------------
 329
 330    function Get_TSD  (T : Tag) return System.Address is
 331    begin
 332       return To_Address (T.TSD);
 333    end Get_TSD;
 334
 335    ----------------
 336    -- Inherit_DT --
 337    ----------------
 338
 339    procedure Inherit_DT
 340     (Old_T       : Tag;
 341      New_T       : Tag;
 342      Entry_Count : Natural)
 343    is
 344    begin
 345       if Old_T /= null then
 346          New_T.Prims_Ptr (1 .. Entry_Count) :=
 347            Old_T.Prims_Ptr (1 .. Entry_Count);
 348       end if;
 349    end Inherit_DT;
 350
 351    -----------------
 352    -- Inherit_TSD --
 353    -----------------
 354
 355    procedure Inherit_TSD (Old_TSD : System.Address; New_Tag : Tag) is
 356       TSD     : constant Type_Specific_Data_Ptr :=
 357                   To_Type_Specific_Data_Ptr (Old_TSD);
 358       New_TSD : Type_Specific_Data renames New_Tag.TSD.all;
 359
 360    begin
 361       if TSD /= null then
 362          New_TSD.Idepth := TSD.Idepth + 1;
 363          New_TSD.Ancestor_Tags (1 .. New_TSD.Idepth)
 364                             := TSD.Ancestor_Tags (0 .. TSD.Idepth);
 365       else
 366          New_TSD.Idepth := 0;
 367       end if;
 368
 369       New_TSD.Ancestor_Tags (0) := New_Tag;
 370    end Inherit_TSD;
 371
 372    ------------------
 373    -- Internal_Tag --
 374    ------------------
 375
 376    function Internal_Tag (External : String) return Tag is
 377       Ext_Copy : aliased String (External'First .. External'Last + 1);
 378       Res      : Tag;
 379
 380    begin
 381       --  Make a copy of the string representing the external tag with
 382       --  a null at the end
 383
 384       Ext_Copy (External'Range) := External;
 385       Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
 386       Res := External_Tag_HTable.Get (Ext_Copy'Address);
 387
 388       if Res = null then
 389          declare
 390             Msg1 : constant String := "unknown tagged type: ";
 391             Msg2 : String (1 .. Msg1'Length + External'Length);
 392
 393          begin
 394             Msg2 (1 .. Msg1'Length) := Msg1;
 395             Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
 396               External;
 397             Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2);
 398          end;
 399       end if;
 400
 401       return Res;
 402    end Internal_Tag;
 403
 404    ------------
 405    -- Length --
 406    ------------
 407
 408    function Length (Str : Cstring_Ptr) return Natural is
 409       Len : Integer := 1;
 410
 411    begin
 412       while Str (Len) /= ASCII.Nul loop
 413          Len := Len + 1;
 414       end loop;
 415
 416       return Len - 1;
 417    end Length;
 418
 419    -----------------
 420    -- Parent_Size --
 421    -----------------
 422
 423    type Acc_Size
 424      is access function (A : System.Address) return Long_Long_Integer;
 425
 426    function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size);
 427    --  The profile of the implicitly defined _size primitive
 428
 429    function Parent_Size
 430      (Obj : System.Address;
 431       T   : Tag) return SSE.Storage_Count
 432    is
 433       Parent_Tag : constant Tag := T.TSD.Ancestor_Tags (1);
 434       --  The tag of the parent type through the dispatch table
 435
 436       F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1));
 437       --  Access to the _size primitive of the parent. We assume that
 438       --  it is always in the first slot of the distatch table
 439
 440    begin
 441       --  Here we compute the size of the _parent field of the object
 442
 443       return SSE.Storage_Count (F.all (Obj));
 444    end Parent_Size;
 445
 446    ----------------
 447    -- Parent_Tag --
 448    ----------------
 449
 450    function Parent_Tag (T : Tag) return Tag is
 451    begin
 452       return T.TSD.Ancestor_Tags (1);
 453    end Parent_Tag;
 454
 455    ------------------
 456    -- Register_Tag --
 457    ------------------
 458
 459    procedure Register_Tag (T : Tag) is
 460    begin
 461       External_Tag_HTable.Set (T);
 462    end Register_Tag;
 463
 464    -----------------------
 465    -- Set_Expanded_Name --
 466    -----------------------
 467
 468    procedure Set_Expanded_Name (T : Tag; Value : System.Address) is
 469    begin
 470       T.TSD.Expanded_Name := To_Cstring_Ptr (Value);
 471    end Set_Expanded_Name;
 472
 473    ----------------------
 474    -- Set_External_Tag --
 475    ----------------------
 476
 477    procedure Set_External_Tag (T : Tag; Value : System.Address) is
 478    begin
 479       T.TSD.External_Tag := To_Cstring_Ptr (Value);
 480    end Set_External_Tag;
 481
 482    ---------------------------
 483    -- Set_Inheritance_Depth --
 484    ---------------------------
 485
 486    procedure Set_Inheritance_Depth
 487      (T     : Tag;
 488       Value : Natural)
 489    is
 490    begin
 491       T.TSD.Idepth := Value;
 492    end Set_Inheritance_Depth;
 493
 494    -------------------------
 495    -- Set_Prim_Op_Address --
 496    -------------------------
 497
 498    procedure Set_Prim_Op_Address
 499      (T        : Tag;
 500       Position : Positive;
 501       Value    : System.Address)
 502    is
 503    begin
 504       T.Prims_Ptr (Position) := Value;
 505    end Set_Prim_Op_Address;
 506
 507    -------------------
 508    -- Set_RC_Offset --
 509    -------------------
 510
 511    procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is
 512    begin
 513       T.TSD.RC_Offset := Value;
 514    end Set_RC_Offset;
 515
 516    ---------------------------
 517    -- Set_Remotely_Callable --
 518    ---------------------------
 519
 520    procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is
 521    begin
 522       if Value then
 523          T.TSD.Remotely_Callable := True;
 524       else
 525          T.TSD.Remotely_Callable := False;
 526       end if;
 527    end Set_Remotely_Callable;
 528
 529    -------------
 530    -- Set_TSD --
 531    -------------
 532
 533    procedure Set_TSD (T : Tag; Value : System.Address) is
 534    begin
 535       T.TSD := To_Type_Specific_Data_Ptr (Value);
 536    end Set_TSD;
 537
 538 end Ada.Tags;