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_External_Tag --
 151    --------------------------
 152
 153    function CPP_Get_External_Tag (T : Vtable_Ptr) return Address is
 154    begin
 155       return To_Address (TSD (T).External_Tag);
 156    end CPP_Get_External_Tag;
 157
 158    -------------------------
 159    -- CPP_Get_Prim_Op_Address --
 160    -------------------------
 161
 162    function CPP_Get_Prim_Op_Address
 163      (T        : Vtable_Ptr;
 164       Position : Positive) return Address
 165    is
 166    begin
 167       return T.Prims_Ptr (Position).Pfn;
 168    end CPP_Get_Prim_Op_Address;
 169
 170    -----------------------
 171    -- CPP_Get_RC_Offset --
 172    -----------------------
 173
 174    function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is
 175       pragma Warnings (Off, T);
 176    begin
 177       return 0;
 178    end CPP_Get_RC_Offset;
 179
 180    -------------------------------
 181    -- CPP_Get_Remotely_Callable --
 182    -------------------------------
 183
 184    function CPP_Get_Remotely_Callable (T : Vtable_Ptr) return Boolean is
 185       pragma Warnings (Off, T);
 186    begin
 187       return True;
 188    end CPP_Get_Remotely_Callable;
 189
 190    -----------------
 191    -- CPP_Get_TSD --
 192    -----------------
 193
 194    function CPP_Get_TSD  (T : Vtable_Ptr) return Address is
 195       use type System.Storage_Elements.Storage_Offset;
 196       TSD_Ptr : constant Addr_Ptr :=
 197                   To_Addr_Ptr (To_Address (T) - CPP_DT_Typeinfo_Ptr_Size);
 198    begin
 199       return TSD_Ptr.all;
 200    end CPP_Get_TSD;
 201
 202    --------------------
 203    -- CPP_Inherit_DT --
 204    --------------------
 205
 206    procedure CPP_Inherit_DT
 207     (Old_T   : Vtable_Ptr;
 208      New_T   : Vtable_Ptr;
 209      Entry_Count : Natural)
 210    is
 211    begin
 212       if Old_T /= null then
 213          New_T.Prims_Ptr (1 .. Entry_Count)
 214            := Old_T.Prims_Ptr (1 .. Entry_Count);
 215       end if;
 216    end CPP_Inherit_DT;
 217
 218    ---------------------
 219    -- CPP_Inherit_TSD --
 220    ---------------------
 221
 222    procedure CPP_Inherit_TSD
 223      (Old_TSD : Address;
 224       New_Tag : Vtable_Ptr)
 225    is
 226       Old_TSD_Ptr : constant Type_Specific_Data_Ptr :=
 227                       To_Type_Specific_Data_Ptr (Old_TSD);
 228
 229       New_TSD_Ptr : constant Type_Specific_Data_Ptr :=
 230                       TSD (New_Tag);
 231
 232    begin
 233       if Old_TSD_Ptr /= null then
 234          New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1;
 235          New_TSD_Ptr.Ancestor_Tags (1 .. New_TSD_Ptr.Idepth) :=
 236            Old_TSD_Ptr.Ancestor_Tags (0 .. Old_TSD_Ptr.Idepth);
 237       else
 238          New_TSD_Ptr.Idepth := 0;
 239       end if;
 240
 241       New_TSD_Ptr.Ancestor_Tags (0) := New_Tag;
 242    end CPP_Inherit_TSD;
 243
 244    ---------------------------
 245    -- CPP_Set_Expanded_Name --
 246    ---------------------------
 247
 248    procedure CPP_Set_Expanded_Name (T : Vtable_Ptr; Value : Address) is
 249    begin
 250       TSD (T).Expanded_Name := To_Cstring_Ptr (Value);
 251    end CPP_Set_Expanded_Name;
 252
 253    --------------------------
 254    -- CPP_Set_External_Tag --
 255    --------------------------
 256
 257    procedure CPP_Set_External_Tag (T : Vtable_Ptr; Value : Address) is
 258    begin
 259       TSD (T).External_Tag := To_Cstring_Ptr (Value);
 260    end CPP_Set_External_Tag;
 261
 262    -----------------------------
 263    -- CPP_Set_Prim_Op_Address --
 264    -----------------------------
 265
 266    procedure CPP_Set_Prim_Op_Address
 267      (T        : Vtable_Ptr;
 268       Position : Positive;
 269       Value    : Address)
 270    is
 271    begin
 272       T.Prims_Ptr (Position).Pfn := Value;
 273    end CPP_Set_Prim_Op_Address;
 274
 275    -----------------------
 276    -- CPP_Set_RC_Offset --
 277    -----------------------
 278
 279    procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is
 280       pragma Warnings (Off, T);
 281       pragma Warnings (Off, Value);
 282    begin
 283       null;
 284    end CPP_Set_RC_Offset;
 285
 286    -------------------------------
 287    -- CPP_Set_Remotely_Callable --
 288    -------------------------------
 289
 290    procedure CPP_Set_Remotely_Callable (T : Vtable_Ptr; Value : Boolean) is
 291       pragma Warnings (Off, T);
 292       pragma Warnings (Off, Value);
 293    begin
 294       null;
 295    end CPP_Set_Remotely_Callable;
 296
 297    -----------------
 298    -- CPP_Set_TSD --
 299    -----------------
 300
 301    procedure CPP_Set_TSD (T : Vtable_Ptr; Value : Address) is
 302       use type System.Storage_Elements.Storage_Offset;
 303       TSD_Ptr : constant Addr_Ptr :=
 304                   To_Addr_Ptr (To_Address (T) - CPP_DT_Typeinfo_Ptr_Size);
 305    begin
 306       TSD_Ptr.all := Value;
 307    end CPP_Set_TSD;
 308
 309    --------------------
 310    -- Displaced_This --
 311    --------------------
 312
 313    function Displaced_This
 314     (Current_This : System.Address;
 315      Vptr         : Vtable_Ptr;
 316      Position     : Positive)
 317      return         System.Address
 318    is
 319       pragma Warnings (Off, Vptr);
 320       pragma Warnings (Off, Position);
 321
 322    begin
 323       return Current_This;
 324
 325       --  why is the following here commented out ???
 326       --  + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1);
 327    end Displaced_This;
 328
 329    -------------------
 330    -- Expanded_Name --
 331    -------------------
 332
 333    function Expanded_Name (T : Vtable_Ptr) return String is
 334       Result : constant Cstring_Ptr := TSD (T).Expanded_Name;
 335    begin
 336       return Result (1 .. Length (Result));
 337    end Expanded_Name;
 338
 339    ------------------
 340    -- External_Tag --
 341    ------------------
 342
 343    function External_Tag (T : Vtable_Ptr) return String is
 344       Result : constant Cstring_Ptr := TSD (T).External_Tag;
 345    begin
 346       return Result (1 .. Length (Result));
 347    end External_Tag;
 348
 349    ------------
 350    -- Length --
 351    ------------
 352
 353    function Length (Str : Cstring_Ptr) return Natural is
 354       Len : Integer := 1;
 355
 356    begin
 357       while Str (Len) /= ASCII.Nul loop
 358          Len := Len + 1;
 359       end loop;
 360
 361       return Len - 1;
 362    end Length;
 363
 364    ------------------
 365    -- Offset_To_Top --
 366    ------------------
 367
 368    function Offset_To_Top (T : Vtable_Ptr) return Integer is
 369       use type System.Storage_Elements.Storage_Offset;
 370
 371       TSD_Ptr : constant Int_Ptr
 372         := To_Int_Ptr (To_Address (T) - CPP_DT_Prologue_Size);
 373    begin
 374       return TSD_Ptr.all;
 375    end Offset_To_Top;
 376
 377    ------------------
 378    -- Typeinfo_Ptr --
 379    ------------------
 380
 381    function Typeinfo_Ptr (T : Vtable_Ptr) return System.Address is
 382       use type System.Storage_Elements.Storage_Offset;
 383       TSD_Ptr : constant Addr_Ptr :=
 384                   To_Addr_Ptr (To_Address (T) - CPP_DT_Typeinfo_Ptr_Size);
 385    begin
 386       return TSD_Ptr.all;
 387    end Typeinfo_Ptr;
 388
 389    ---------
 390    -- TSD --
 391    ---------
 392
 393    function TSD (T : Vtable_Ptr) return Type_Specific_Data_Ptr is
 394    begin
 395       return To_Type_Specific_Data_Ptr (CPP_Get_TSD (T));
 396    end TSD;
 397
 398 end Interfaces.CPP;