gcc/ada/i-cpp.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                       I N T E R F A C E S . C P P                        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2005, 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.Tags;                use Ada.Tags;
  35 with System;                  use System;
  36 with System.Storage_Elements; use System.Storage_Elements;
  37
  38 package body Interfaces.CPP is
  39
  40 --  Structure of the Dispatch Table
  41
  42 --           +-----------------------+
  43 --           |     Offset_To_Top     |
  44 --           +-----------------------+
  45 --           | Typeinfo_Ptr/TSD_Ptr  |----> Type Specific Data
  46 --  Tag ---> +-----------------------+      +-------------------+
  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    --  The declarations below need (extensive) comments ???
  65
  66    subtype Cstring is String (Positive);
  67    type Cstring_Ptr is access all Cstring;
  68    type Tag_Table is array (Natural range <>) of Vtable_Ptr;
  69    pragma Suppress_Initialization (Tag_Table);
  70
  71    type Type_Specific_Data is record
  72       Idepth        : Natural;
  73       Expanded_Name : Cstring_Ptr;
  74       External_Tag  : Cstring_Ptr;
  75       HT_Link       : Tag;
  76       Ancestor_Tags : Tag_Table (Natural);
  77    end record;
  78
  79    type Vtable_Entry is record
  80      Pfn : System.Address;
  81    end record;
  82
  83    type Vtable_Entry_Array is array (Positive range <>) of Vtable_Entry;
  84
  85    type VTable is record
  86       --  Offset_To_Top : Integer;
  87       --  Typeinfo_Ptr  : System.Address; -- TSD is currently also here???
  88       Prims_Ptr  : Vtable_Entry_Array (Positive);
  89    end record;
  90    --  Note: See comment in a-tags.adb explaining why the components
  91    --        Offset_To_Top and Typeinfo_Ptr have been commented out.
  92    --  -----------------------------------------------------------------------
  93    --  The size of the Prims_Ptr array actually depends on the tagged type to
  94    --  which it applies. For each tagged type, the expander computes the
  95    --  actual array size, allocates the Dispatch_Table record accordingly, and
  96    --  generates code that displaces the base of the record after the
  97    --  Typeinfo_Ptr component. For this reason the first two components have
  98    --  been commented in the previous declaration. The access to these
  99    --  components is done by means of local functions.
 100
 101    ---------------------------
 102    -- Unchecked Conversions --
 103    ---------------------------
 104
 105    type Int_Ptr is access Integer;
 106
 107    function To_Int_Ptr is
 108       new Unchecked_Conversion (System.Address, Int_Ptr);
 109
 110    function To_Cstring_Ptr is
 111      new Unchecked_Conversion (Address, Cstring_Ptr);
 112
 113    function To_Address is
 114      new Unchecked_Conversion (Cstring_Ptr, Address);
 115
 116    -----------------------
 117    -- Local Subprograms --
 118    -----------------------
 119
 120    function Length (Str : Cstring_Ptr) return Natural;
 121    --  Length of string represented by the given pointer (treating the string
 122    --  as a C-style string, which is Nul terminated).
 123
 124    function Offset_To_Top (T : Vtable_Ptr) return Integer;
 125    --  Returns the current value of the offset_to_top component available in
 126    --  the prologue of the dispatch table.
 127
 128    function Typeinfo_Ptr (T : Vtable_Ptr) return System.Address;
 129    --  Returns the current value of the typeinfo_ptr component available in
 130    --  the prologue of the dispatch table.
 131
 132    pragma Unreferenced (Offset_To_Top);
 133    pragma Unreferenced (Typeinfo_Ptr);
 134    --  These functions will be used for full compatibility with the C++ ABI
 135
 136    -----------------------
 137    -- CPP_CW_Membership --
 138    -----------------------
 139
 140    function CPP_CW_Membership
 141      (Obj_Tag : Vtable_Ptr;
 142       Typ_Tag : Vtable_Ptr) return Boolean
 143    is
 144       Pos : constant Integer := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
 145    begin
 146       return Pos >= 0 and then TSD (Obj_Tag).Ancestor_Tags (Pos) = Typ_Tag;
 147    end CPP_CW_Membership;
 148
 149    ---------------------------
 150    -- CPP_Get_Expanded_Name --
 151    ---------------------------
 152
 153    function CPP_Get_Expanded_Name (T : Vtable_Ptr) return Address is
 154    begin
 155       return To_Address (TSD (T).Expanded_Name);
 156    end CPP_Get_Expanded_Name;
 157
 158    --------------------------
 159    -- CPP_Get_External_Tag --
 160    --------------------------
 161
 162    function CPP_Get_External_Tag (T : Vtable_Ptr) return Address is
 163    begin
 164       return To_Address (TSD (T).External_Tag);
 165    end CPP_Get_External_Tag;
 166
 167    -------------------------------
 168    -- CPP_Get_Inheritance_Depth --
 169    -------------------------------
 170
 171    function CPP_Get_Inheritance_Depth (T : Vtable_Ptr) return Natural is
 172    begin
 173       return TSD (T).Idepth;
 174    end CPP_Get_Inheritance_Depth;
 175
 176    -------------------------
 177    -- CPP_Get_Prim_Op_Address --
 178    -------------------------
 179
 180    function CPP_Get_Prim_Op_Address
 181      (T        : Vtable_Ptr;
 182       Position : Positive) return Address
 183    is
 184    begin
 185       return T.Prims_Ptr (Position).Pfn;
 186    end CPP_Get_Prim_Op_Address;
 187
 188    -----------------------
 189    -- CPP_Get_RC_Offset --
 190    -----------------------
 191
 192    function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is
 193       pragma Warnings (Off, T);
 194    begin
 195       return 0;
 196    end CPP_Get_RC_Offset;
 197
 198    -------------------------------
 199    -- CPP_Get_Remotely_Callable --
 200    -------------------------------
 201
 202    function CPP_Get_Remotely_Callable (T : Vtable_Ptr) return Boolean is
 203       pragma Warnings (Off, T);
 204    begin
 205       return True;
 206    end CPP_Get_Remotely_Callable;
 207
 208    -----------------
 209    -- CPP_Get_TSD --
 210    -----------------
 211
 212    function CPP_Get_TSD  (T : Vtable_Ptr) return Address is
 213       use type System.Storage_Elements.Storage_Offset;
 214       TSD_Ptr : constant Addr_Ptr :=
 215                   To_Addr_Ptr (To_Address (T) - CPP_DT_Typeinfo_Ptr_Size);
 216    begin
 217       return TSD_Ptr.all;
 218    end CPP_Get_TSD;
 219
 220    --------------------
 221    -- CPP_Inherit_DT --
 222    --------------------
 223
 224    procedure CPP_Inherit_DT
 225     (Old_T   : Vtable_Ptr;
 226      New_T   : Vtable_Ptr;
 227      Entry_Count : Natural)
 228    is
 229    begin
 230       if Old_T /= null then
 231          New_T.Prims_Ptr (1 .. Entry_Count)
 232            := Old_T.Prims_Ptr (1 .. Entry_Count);
 233       end if;
 234    end CPP_Inherit_DT;
 235
 236    ---------------------
 237    -- CPP_Inherit_TSD --
 238    ---------------------
 239
 240    procedure CPP_Inherit_TSD
 241      (Old_TSD : Address;
 242       New_Tag : Vtable_Ptr)
 243    is
 244       Old_TSD_Ptr : constant Type_Specific_Data_Ptr :=
 245                       To_Type_Specific_Data_Ptr (Old_TSD);
 246
 247       New_TSD_Ptr : constant Type_Specific_Data_Ptr :=
 248                       TSD (New_Tag);
 249
 250    begin
 251       if Old_TSD_Ptr /= null then
 252          New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1;
 253          New_TSD_Ptr.Ancestor_Tags (1 .. New_TSD_Ptr.Idepth) :=
 254            Old_TSD_Ptr.Ancestor_Tags (0 .. Old_TSD_Ptr.Idepth);
 255       else
 256          New_TSD_Ptr.Idepth := 0;
 257       end if;
 258
 259       New_TSD_Ptr.Ancestor_Tags (0) := New_Tag;
 260    end CPP_Inherit_TSD;
 261
 262    ---------------------------
 263    -- CPP_Set_Expanded_Name --
 264    ---------------------------
 265
 266    procedure CPP_Set_Expanded_Name (T : Vtable_Ptr; Value : Address) is
 267    begin
 268       TSD (T).Expanded_Name := To_Cstring_Ptr (Value);
 269    end CPP_Set_Expanded_Name;
 270
 271    --------------------------
 272    -- CPP_Set_External_Tag --
 273    --------------------------
 274
 275    procedure CPP_Set_External_Tag (T : Vtable_Ptr; Value : Address) is
 276    begin
 277       TSD (T).External_Tag := To_Cstring_Ptr (Value);
 278    end CPP_Set_External_Tag;
 279
 280    -------------------------------
 281    -- CPP_Set_Inheritance_Depth --
 282    -------------------------------
 283
 284    procedure CPP_Set_Inheritance_Depth
 285      (T     : Vtable_Ptr;
 286       Value : Natural)
 287    is
 288    begin
 289       TSD (T).Idepth := Value;
 290    end CPP_Set_Inheritance_Depth;
 291
 292    -----------------------------
 293    -- CPP_Set_Prim_Op_Address --
 294    -----------------------------
 295
 296    procedure CPP_Set_Prim_Op_Address
 297      (T        : Vtable_Ptr;
 298       Position : Positive;
 299       Value    : Address)
 300    is
 301    begin
 302       T.Prims_Ptr (Position).Pfn := Value;
 303    end CPP_Set_Prim_Op_Address;
 304
 305    -----------------------
 306    -- CPP_Set_RC_Offset --
 307    -----------------------
 308
 309    procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is
 310       pragma Warnings (Off, T);
 311       pragma Warnings (Off, Value);
 312    begin
 313       null;
 314    end CPP_Set_RC_Offset;
 315
 316    -------------------------------
 317    -- CPP_Set_Remotely_Callable --
 318    -------------------------------
 319
 320    procedure CPP_Set_Remotely_Callable (T : Vtable_Ptr; Value : Boolean) is
 321       pragma Warnings (Off, T);
 322       pragma Warnings (Off, Value);
 323    begin
 324       null;
 325    end CPP_Set_Remotely_Callable;
 326
 327    -----------------
 328    -- CPP_Set_TSD --
 329    -----------------
 330
 331    procedure CPP_Set_TSD (T : Vtable_Ptr; Value : Address) is
 332       use type System.Storage_Elements.Storage_Offset;
 333       TSD_Ptr : constant Addr_Ptr :=
 334                   To_Addr_Ptr (To_Address (T) - CPP_DT_Typeinfo_Ptr_Size);
 335    begin
 336       TSD_Ptr.all := Value;
 337    end CPP_Set_TSD;
 338
 339    --------------------
 340    -- Displaced_This --
 341    --------------------
 342
 343    function Displaced_This
 344     (Current_This : System.Address;
 345      Vptr         : Vtable_Ptr;
 346      Position     : Positive)
 347      return         System.Address
 348    is
 349       pragma Warnings (Off, Vptr);
 350       pragma Warnings (Off, Position);
 351
 352    begin
 353       return Current_This;
 354
 355       --  why is the following here commented out ???
 356       --  + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1);
 357    end Displaced_This;
 358
 359    -------------------
 360    -- Expanded_Name --
 361    -------------------
 362
 363    function Expanded_Name (T : Vtable_Ptr) return String is
 364       Result : constant Cstring_Ptr := TSD (T).Expanded_Name;
 365    begin
 366       return Result (1 .. Length (Result));
 367    end Expanded_Name;
 368
 369    ------------------
 370    -- External_Tag --
 371    ------------------
 372
 373    function External_Tag (T : Vtable_Ptr) return String is
 374       Result : constant Cstring_Ptr := TSD (T).External_Tag;
 375    begin
 376       return Result (1 .. Length (Result));
 377    end External_Tag;
 378
 379    ------------
 380    -- Length --
 381    ------------
 382
 383    function Length (Str : Cstring_Ptr) return Natural is
 384       Len : Integer := 1;
 385
 386    begin
 387       while Str (Len) /= ASCII.Nul loop
 388          Len := Len + 1;
 389       end loop;
 390
 391       return Len - 1;
 392    end Length;
 393
 394    ------------------
 395    -- Offset_To_Top --
 396    ------------------
 397
 398    function Offset_To_Top (T : Vtable_Ptr) return Integer is
 399       use type System.Storage_Elements.Storage_Offset;
 400
 401       TSD_Ptr : constant Int_Ptr
 402         := To_Int_Ptr (To_Address (T) - CPP_DT_Prologue_Size);
 403    begin
 404       return TSD_Ptr.all;
 405    end Offset_To_Top;
 406
 407    ------------------
 408    -- Typeinfo_Ptr --
 409    ------------------
 410
 411    function Typeinfo_Ptr (T : Vtable_Ptr) return System.Address is
 412       use type System.Storage_Elements.Storage_Offset;
 413       TSD_Ptr : constant Addr_Ptr :=
 414                   To_Addr_Ptr (To_Address (T) - CPP_DT_Typeinfo_Ptr_Size);
 415    begin
 416       return TSD_Ptr.all;
 417    end Typeinfo_Ptr;
 418
 419    ---------
 420    -- TSD --
 421    ---------
 422
 423    function TSD (T : Vtable_Ptr) return Type_Specific_Data_Ptr is
 424    begin
 425       return To_Type_Specific_Data_Ptr (CPP_Get_TSD (T));
 426    end TSD;
 427
 428 end Interfaces.CPP;