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 --                                                                          --
  10 --          Copyright (C) 1992-2002 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT was originally developed  by the GNAT team at  New York University. --
  31 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 with Ada.Exceptions;
  36 with Unchecked_Conversion;
  37 with GNAT.HTable;
  38
  39 pragma Elaborate_All (GNAT.HTable);
  40
  41 package body Ada.Tags is
  42
  43 --  Structure of the GNAT Dispatch Table
  44
  45 --   +----------------------+
  46 --   |      TSD pointer  ---|-----> Type Specific Data
  47 --   +----------------------+       +-------------------+
  48 --   | table of             |       | inheritance depth |
  49 --   :   primitive ops      :       +-------------------+
  50 --   |     pointers         |       |   expanded name   |
  51 --   +----------------------+       +-------------------+
  52 --                                  |   external tag    |
  53 --                                  +-------------------+
  54 --                                  |   Hash table link |
  55 --                                  +-------------------+
  56 --                                  | Remotely Callable |
  57 --                                  +-------------------+
  58 --                                  | Rec Ctrler offset |
  59 --                                  +-------------------+
  60 --                                  | table of          |
  61 --                                  :   ancestor        :
  62 --                                  |      tags         |
  63 --                                  +-------------------+
  64
  65    subtype Cstring is String (Positive);
  66    type Cstring_Ptr is access all Cstring;
  67    type Tag_Table is array (Natural range <>) of Tag;
  68    pragma Suppress_Initialization (Tag_Table);
  69
  70    type Wide_Boolean is (False, True);
  71    for Wide_Boolean'Size use Standard'Address_Size;
  72
  73    type Type_Specific_Data is record
  74       Idepth             : Natural;
  75       Expanded_Name      : Cstring_Ptr;
  76       External_Tag       : Cstring_Ptr;
  77       HT_Link            : Tag;
  78       Remotely_Callable  : Wide_Boolean;
  79       RC_Offset          : SSE.Storage_Offset;
  80       Ancestor_Tags      : Tag_Table (Natural);
  81    end record;
  82
  83    type Dispatch_Table is record
  84       TSD       : Type_Specific_Data_Ptr;
  85       Prims_Ptr : Address_Array (Positive);
  86    end record;
  87
  88    -------------------------------------------
  89    -- Unchecked Conversions for Tag and TSD --
  90    -------------------------------------------
  91
  92    function To_Type_Specific_Data_Ptr is
  93      new Unchecked_Conversion (S.Address, Type_Specific_Data_Ptr);
  94
  95    function To_Address is
  96      new Unchecked_Conversion (Type_Specific_Data_Ptr, S.Address);
  97
  98    ---------------------------------------------
  99    -- Unchecked Conversions for String Fields --
 100    ---------------------------------------------
 101
 102    function To_Cstring_Ptr is
 103      new Unchecked_Conversion (S.Address, Cstring_Ptr);
 104
 105    function To_Address is
 106      new Unchecked_Conversion (Cstring_Ptr, S.Address);
 107
 108    -----------------------
 109    -- Local Subprograms --
 110    -----------------------
 111
 112    function Length (Str : Cstring_Ptr) return Natural;
 113    --  Length of string represented by the given pointer (treating the
 114    --  string as a C-style string, which is Nul terminated).
 115
 116    -------------------------
 117    -- External_Tag_HTable --
 118    -------------------------
 119
 120    type HTable_Headers is range 1 .. 64;
 121
 122    --  The following internal package defines the routines used for
 123    --  the instantiation of a new GNAT.HTable.Static_HTable (see
 124    --  below). See spec in g-htable.ads for details of usage.
 125
 126    package HTable_Subprograms is
 127       procedure Set_HT_Link (T : Tag; Next : Tag);
 128       function  Get_HT_Link (T : Tag) return Tag;
 129       function Hash (F : S.Address) return HTable_Headers;
 130       function Equal (A, B : S.Address) return Boolean;
 131    end HTable_Subprograms;
 132
 133    package External_Tag_HTable is new GNAT.HTable.Static_HTable (
 134      Header_Num => HTable_Headers,
 135      Element    => Dispatch_Table,
 136      Elmt_Ptr   => Tag,
 137      Null_Ptr   => null,
 138      Set_Next   => HTable_Subprograms.Set_HT_Link,
 139      Next       => HTable_Subprograms.Get_HT_Link,
 140      Key        => S.Address,
 141      Get_Key    => Get_External_Tag,
 142      Hash       => HTable_Subprograms.Hash,
 143      Equal      => HTable_Subprograms.Equal);
 144
 145    ------------------------
 146    -- HTable_Subprograms --
 147    ------------------------
 148
 149    --  Bodies of routines for hash table instantiation
 150
 151    package body HTable_Subprograms is
 152
 153    -----------
 154    -- Equal --
 155    -----------
 156
 157       function Equal (A, B : S.Address) return Boolean is
 158          Str1 : Cstring_Ptr := To_Cstring_Ptr (A);
 159          Str2 : Cstring_Ptr := To_Cstring_Ptr (B);
 160          J    : Integer := 1;
 161
 162       begin
 163          loop
 164             if Str1 (J) /= Str2 (J) then
 165                return False;
 166
 167             elsif Str1 (J) = ASCII.NUL then
 168                return True;
 169
 170             else
 171                J := J + 1;
 172             end if;
 173          end loop;
 174       end Equal;
 175
 176       -----------------
 177       -- Get_HT_Link --
 178       -----------------
 179
 180       function Get_HT_Link (T : Tag) return Tag is
 181       begin
 182          return T.TSD.HT_Link;
 183       end Get_HT_Link;
 184
 185       ----------
 186       -- Hash --
 187       ----------
 188
 189       function Hash (F : S.Address) return HTable_Headers is
 190          function H is new GNAT.HTable.Hash (HTable_Headers);
 191          Str : Cstring_Ptr := To_Cstring_Ptr (F);
 192          Res : constant HTable_Headers := H (Str (1 .. Length (Str)));
 193
 194       begin
 195          return Res;
 196       end Hash;
 197
 198       -----------------
 199       -- Set_HT_Link --
 200       -----------------
 201
 202       procedure Set_HT_Link (T : Tag; Next : Tag) is
 203       begin
 204          T.TSD.HT_Link := Next;
 205       end Set_HT_Link;
 206
 207    end HTable_Subprograms;
 208
 209    --------------------
 210    --  CW_Membership --
 211    --------------------
 212
 213    --  Canonical implementation of Classwide Membership corresponding to:
 214
 215    --     Obj in Typ'Class
 216
 217    --  Each dispatch table contains a reference to a table of ancestors
 218    --  (Ancestor_Tags) and a count of the level of inheritance "Idepth" .
 219
 220    --  Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
 221    --  contained in the dispatch table referenced by Obj'Tag . Knowing the
 222    --  level of inheritance of both types, this can be computed in constant
 223    --  time by the formula:
 224
 225    --   Obj'tag.TSD.Ancestor_Tags (Obj'tag.TSD.Idepth - Typ'tag.TSD.Idepth)
 226    --     = Typ'tag
 227
 228    function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
 229       Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth;
 230
 231    begin
 232       return Pos >= 0 and then Obj_Tag.TSD.Ancestor_Tags (Pos) = Typ_Tag;
 233    end CW_Membership;
 234
 235    -------------------
 236    -- Expanded_Name --
 237    -------------------
 238
 239    function Expanded_Name (T : Tag) return String is
 240       Result : Cstring_Ptr := T.TSD.Expanded_Name;
 241
 242    begin
 243       return Result (1 .. Length (Result));
 244    end Expanded_Name;
 245
 246    ------------------
 247    -- External_Tag --
 248    ------------------
 249
 250    function External_Tag (T : Tag) return String is
 251       Result : Cstring_Ptr := T.TSD.External_Tag;
 252
 253    begin
 254       return Result (1 .. Length (Result));
 255    end External_Tag;
 256
 257    -----------------------
 258    -- Get_Expanded_Name --
 259    -----------------------
 260
 261    function Get_Expanded_Name (T : Tag) return S.Address is
 262    begin
 263       return To_Address (T.TSD.Expanded_Name);
 264    end Get_Expanded_Name;
 265
 266    ----------------------
 267    -- Get_External_Tag --
 268    ----------------------
 269
 270    function Get_External_Tag (T : Tag) return S.Address is
 271    begin
 272       return To_Address (T.TSD.External_Tag);
 273    end Get_External_Tag;
 274
 275    ---------------------------
 276    -- Get_Inheritance_Depth --
 277    ---------------------------
 278
 279    function Get_Inheritance_Depth (T : Tag) return Natural is
 280    begin
 281       return T.TSD.Idepth;
 282    end Get_Inheritance_Depth;
 283
 284    -------------------------
 285    -- Get_Prim_Op_Address --
 286    -------------------------
 287
 288    function Get_Prim_Op_Address
 289      (T        : Tag;
 290       Position : Positive)
 291       return     S.Address
 292    is
 293    begin
 294       return T.Prims_Ptr (Position);
 295    end Get_Prim_Op_Address;
 296
 297    -------------------
 298    -- Get_RC_Offset --
 299    -------------------
 300
 301    function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is
 302    begin
 303       return T.TSD.RC_Offset;
 304    end Get_RC_Offset;
 305
 306    ---------------------------
 307    -- Get_Remotely_Callable --
 308    ---------------------------
 309
 310    function Get_Remotely_Callable (T : Tag) return Boolean is
 311    begin
 312       return T.TSD.Remotely_Callable = True;
 313    end Get_Remotely_Callable;
 314
 315    -------------
 316    -- Get_TSD --
 317    -------------
 318
 319    function Get_TSD  (T : Tag) return S.Address is
 320    begin
 321       return To_Address (T.TSD);
 322    end Get_TSD;
 323
 324    ----------------
 325    -- Inherit_DT --
 326    ----------------
 327
 328    procedure Inherit_DT
 329     (Old_T       : Tag;
 330      New_T       : Tag;
 331      Entry_Count : Natural)
 332    is
 333    begin
 334       if Old_T /= null then
 335          New_T.Prims_Ptr (1 .. Entry_Count) :=
 336            Old_T.Prims_Ptr (1 .. Entry_Count);
 337       end if;
 338    end Inherit_DT;
 339
 340    -----------------
 341    -- Inherit_TSD --
 342    -----------------
 343
 344    procedure Inherit_TSD (Old_TSD : S.Address; New_Tag : Tag) is
 345       TSD     : constant Type_Specific_Data_Ptr :=
 346                   To_Type_Specific_Data_Ptr (Old_TSD);
 347       New_TSD : Type_Specific_Data renames New_Tag.TSD.all;
 348
 349    begin
 350       if TSD /= null then
 351          New_TSD.Idepth := TSD.Idepth + 1;
 352          New_TSD.Ancestor_Tags (1 .. New_TSD.Idepth)
 353                             := TSD.Ancestor_Tags (0 .. TSD.Idepth);
 354       else
 355          New_TSD.Idepth := 0;
 356       end if;
 357
 358       New_TSD.Ancestor_Tags (0) := New_Tag;
 359    end Inherit_TSD;
 360
 361    ------------------
 362    -- Internal_Tag --
 363    ------------------
 364
 365    function Internal_Tag (External : String) return Tag is
 366       Ext_Copy : aliased String (External'First .. External'Last + 1);
 367       Res      : Tag;
 368
 369    begin
 370       --  Make a copy of the string representing the external tag with
 371       --  a null at the end
 372
 373       Ext_Copy (External'Range) := External;
 374       Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
 375       Res := External_Tag_HTable.Get (Ext_Copy'Address);
 376
 377       if Res = null then
 378          declare
 379             Msg1 : constant String := "unknown tagged type: ";
 380             Msg2 : String (1 .. Msg1'Length + External'Length);
 381
 382          begin
 383             Msg2 (1 .. Msg1'Length) := Msg1;
 384             Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
 385               External;
 386             Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2);
 387          end;
 388       end if;
 389
 390       return Res;
 391    end Internal_Tag;
 392
 393    ------------
 394    -- Length --
 395    ------------
 396
 397    function Length (Str : Cstring_Ptr) return Natural is
 398       Len : Integer := 1;
 399
 400    begin
 401       while Str (Len) /= ASCII.Nul loop
 402          Len := Len + 1;
 403       end loop;
 404
 405       return Len - 1;
 406    end Length;
 407
 408    -----------------
 409    -- Parent_Size --
 410    -----------------
 411
 412    --  Fake type with a tag as first component. Should match the
 413    --  layout of all tagged types.
 414
 415    type T is record
 416       A : Tag;
 417    end record;
 418
 419    type T_Ptr is access all T;
 420
 421    function To_T_Ptr is new Unchecked_Conversion (S.Address, T_Ptr);
 422
 423    --  The profile of the implicitly defined _size primitive
 424
 425    type Acc_Size is access function (A : S.Address) return Long_Long_Integer;
 426    function To_Acc_Size is new Unchecked_Conversion (S.Address, Acc_Size);
 427
 428    function Parent_Size (Obj : S.Address) return SSE.Storage_Count is
 429
 430       --  Get the tag of the object
 431
 432       Obj_Tag : constant Tag      := To_T_Ptr (Obj).A;
 433
 434       --  Get the tag of the parent type through the dispatch table
 435
 436       Parent_Tag : constant Tag      := Obj_Tag.TSD.Ancestor_Tags (1);
 437
 438       --  Get an access to the _size primitive of the parent. We assume that
 439       --  it is always in the first slot of the distatch table
 440
 441       F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1));
 442
 443    begin
 444       --  Here we compute the size of the _parent field of the object
 445
 446       return SSE.Storage_Count (F.all (Obj));
 447    end Parent_Size;
 448
 449    ------------------
 450    -- Register_Tag --
 451    ------------------
 452
 453    procedure Register_Tag (T : Tag) is
 454    begin
 455       External_Tag_HTable.Set (T);
 456    end Register_Tag;
 457
 458    -----------------------
 459    -- Set_Expanded_Name --
 460    -----------------------
 461
 462    procedure Set_Expanded_Name (T : Tag; Value : S.Address) is
 463    begin
 464       T.TSD.Expanded_Name := To_Cstring_Ptr (Value);
 465    end Set_Expanded_Name;
 466
 467    ----------------------
 468    -- Set_External_Tag --
 469    ----------------------
 470
 471    procedure Set_External_Tag (T : Tag; Value : S.Address) is
 472    begin
 473       T.TSD.External_Tag := To_Cstring_Ptr (Value);
 474    end Set_External_Tag;
 475
 476    ---------------------------
 477    -- Set_Inheritance_Depth --
 478    ---------------------------
 479
 480    procedure Set_Inheritance_Depth
 481      (T     : Tag;
 482       Value : Natural)
 483    is
 484    begin
 485       T.TSD.Idepth := Value;
 486    end Set_Inheritance_Depth;
 487
 488    -------------------------
 489    -- Set_Prim_Op_Address --
 490    -------------------------
 491
 492    procedure Set_Prim_Op_Address
 493      (T        : Tag;
 494       Position : Positive;
 495       Value    : S.Address)
 496    is
 497    begin
 498       T.Prims_Ptr (Position) := Value;
 499    end Set_Prim_Op_Address;
 500
 501    -------------------
 502    -- Set_RC_Offset --
 503    -------------------
 504
 505    procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is
 506    begin
 507       T.TSD.RC_Offset := Value;
 508    end Set_RC_Offset;
 509
 510    ---------------------------
 511    -- Set_Remotely_Callable --
 512    ---------------------------
 513
 514    procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is
 515    begin
 516       if Value then
 517          T.TSD.Remotely_Callable := True;
 518       else
 519          T.TSD.Remotely_Callable := False;
 520       end if;
 521    end Set_Remotely_Callable;
 522
 523    -------------
 524    -- Set_TSD --
 525    -------------
 526
 527    procedure Set_TSD (T : Tag; Value : S.Address) is
 528    begin
 529       T.TSD := To_Type_Specific_Data_Ptr (Value);
 530    end Set_TSD;
 531
 532 end Ada.Tags;