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