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