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