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