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-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.Tags;                use Ada.Tags;
  35 with System;                  use System;
  36 with System.Storage_Elements; use System.Storage_Elements;
  37 with Unchecked_Conversion;
  38
  39 package body Interfaces.CPP is
  40
  41    subtype Cstring is String (Positive);
  42    type Cstring_Ptr is access all Cstring;
  43    type Tag_Table is array (Natural range <>) of Vtable_Ptr;
  44    pragma Suppress_Initialization (Tag_Table);
  45
  46    type Type_Specific_Data is record
  47       Idepth        : Natural;
  48       Expanded_Name : Cstring_Ptr;
  49       External_Tag  : Cstring_Ptr;
  50       HT_Link       : Tag;
  51       Ancestor_Tags : Tag_Table (Natural);
  52    end record;
  53
  54    type Vtable_Entry is record
  55      Pfn    : System.Address;
  56    end record;
  57
  58    type Type_Specific_Data_Ptr is access all Type_Specific_Data;
  59    type Vtable_Entry_Array is array (Positive range <>) of Vtable_Entry;
  60
  61    type VTable is record
  62       Prims_Ptr : Vtable_Entry_Array (Positive);
  63       TSD       : Type_Specific_Data_Ptr;
  64    end record;
  65
  66    --------------------------------------------------------
  67    -- Unchecked Conversions for Tag, Vtable_Ptr, and TSD --
  68    --------------------------------------------------------
  69
  70    function To_Type_Specific_Data_Ptr is
  71      new Unchecked_Conversion (Address, Type_Specific_Data_Ptr);
  72
  73    function To_Address is
  74      new Unchecked_Conversion (Type_Specific_Data_Ptr, Address);
  75
  76    ---------------------------------------------
  77    -- Unchecked Conversions for String Fields --
  78    ---------------------------------------------
  79
  80    function To_Cstring_Ptr is
  81      new Unchecked_Conversion (Address, Cstring_Ptr);
  82
  83    function To_Address is
  84      new Unchecked_Conversion (Cstring_Ptr, Address);
  85
  86    -----------------------
  87    -- Local Subprograms --
  88    -----------------------
  89
  90    function Length (Str : Cstring_Ptr) return Natural;
  91    --  Length of string represented by the given pointer (treating the
  92    --  string as a C-style string, which is Nul terminated).
  93
  94    -----------------------
  95    -- CPP_CW_Membership --
  96    -----------------------
  97
  98    function CPP_CW_Membership
  99      (Obj_Tag : Vtable_Ptr;
 100       Typ_Tag : Vtable_Ptr)
 101       return Boolean
 102    is
 103       Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth;
 104    begin
 105       return Pos >= 0 and then Obj_Tag.TSD.Ancestor_Tags (Pos) = Typ_Tag;
 106    end CPP_CW_Membership;
 107
 108    ---------------------------
 109    -- CPP_Get_Expanded_Name --
 110    ---------------------------
 111
 112    function CPP_Get_Expanded_Name (T : Vtable_Ptr) return Address is
 113    begin
 114       return To_Address (T.TSD.Expanded_Name);
 115    end CPP_Get_Expanded_Name;
 116
 117    --------------------------
 118    -- CPP_Get_External_Tag --
 119    --------------------------
 120
 121    function CPP_Get_External_Tag (T : Vtable_Ptr) return Address is
 122    begin
 123       return To_Address (T.TSD.External_Tag);
 124    end CPP_Get_External_Tag;
 125
 126    -------------------------------
 127    -- CPP_Get_Inheritance_Depth --
 128    -------------------------------
 129
 130    function CPP_Get_Inheritance_Depth (T : Vtable_Ptr) return Natural is
 131    begin
 132       return T.TSD.Idepth;
 133    end CPP_Get_Inheritance_Depth;
 134
 135    -------------------------
 136    -- CPP_Get_Prim_Op_Address --
 137    -------------------------
 138
 139    function CPP_Get_Prim_Op_Address
 140      (T        : Vtable_Ptr;
 141       Position : Positive)
 142       return Address is
 143    begin
 144       return T.Prims_Ptr (Position).Pfn;
 145    end CPP_Get_Prim_Op_Address;
 146
 147    -----------------------
 148    -- CPP_Get_RC_Offset --
 149    -----------------------
 150
 151    function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is
 152       pragma Warnings (Off, T);
 153
 154    begin
 155       return 0;
 156    end CPP_Get_RC_Offset;
 157
 158    -------------------------------
 159    -- CPP_Get_Remotely_Callable --
 160    -------------------------------
 161
 162    function CPP_Get_Remotely_Callable (T : Vtable_Ptr) return Boolean is
 163       pragma Warnings (Off, T);
 164
 165    begin
 166       return True;
 167    end CPP_Get_Remotely_Callable;
 168
 169    -----------------
 170    -- CPP_Get_TSD --
 171    -----------------
 172
 173    function CPP_Get_TSD  (T : Vtable_Ptr) return Address is
 174    begin
 175       return To_Address (T.TSD);
 176    end CPP_Get_TSD;
 177
 178    --------------------
 179    -- CPP_Inherit_DT --
 180    --------------------
 181
 182    procedure CPP_Inherit_DT
 183     (Old_T   : Vtable_Ptr;
 184      New_T   : Vtable_Ptr;
 185      Entry_Count : Natural)
 186    is
 187    begin
 188       if Old_T /= null then
 189          New_T.Prims_Ptr (1 .. Entry_Count)
 190            := Old_T.Prims_Ptr (1 .. Entry_Count);
 191       end if;
 192    end CPP_Inherit_DT;
 193
 194    ---------------------
 195    -- CPP_Inherit_TSD --
 196    ---------------------
 197
 198    procedure CPP_Inherit_TSD
 199      (Old_TSD : Address;
 200       New_Tag : Vtable_Ptr)
 201    is
 202       TSD : constant Type_Specific_Data_Ptr
 203         := To_Type_Specific_Data_Ptr (Old_TSD);
 204
 205       New_TSD : Type_Specific_Data renames New_Tag.TSD.all;
 206
 207    begin
 208       if TSD /= null then
 209          New_TSD.Idepth := TSD.Idepth + 1;
 210          New_TSD.Ancestor_Tags (1 .. New_TSD.Idepth)
 211            := TSD.Ancestor_Tags (0 .. TSD.Idepth);
 212       else
 213          New_TSD.Idepth := 0;
 214       end if;
 215
 216       New_TSD.Ancestor_Tags (0) := New_Tag;
 217    end CPP_Inherit_TSD;
 218
 219    ---------------------------
 220    -- CPP_Set_Expanded_Name --
 221    ---------------------------
 222
 223    procedure CPP_Set_Expanded_Name (T : Vtable_Ptr; Value : Address) is
 224    begin
 225       T.TSD.Expanded_Name := To_Cstring_Ptr (Value);
 226    end CPP_Set_Expanded_Name;
 227
 228    --------------------------
 229    -- CPP_Set_External_Tag --
 230    --------------------------
 231
 232    procedure CPP_Set_External_Tag (T : Vtable_Ptr; Value : Address) is
 233    begin
 234       T.TSD.External_Tag := To_Cstring_Ptr (Value);
 235    end CPP_Set_External_Tag;
 236
 237    -------------------------------
 238    -- CPP_Set_Inheritance_Depth --
 239    -------------------------------
 240
 241    procedure CPP_Set_Inheritance_Depth
 242      (T     : Vtable_Ptr;
 243       Value : Natural)
 244    is
 245    begin
 246       T.TSD.Idepth := Value;
 247    end CPP_Set_Inheritance_Depth;
 248
 249    -----------------------------
 250    -- CPP_Set_Prim_Op_Address --
 251    -----------------------------
 252
 253    procedure CPP_Set_Prim_Op_Address
 254      (T        : Vtable_Ptr;
 255       Position : Positive;
 256       Value    : Address)
 257    is
 258    begin
 259       T.Prims_Ptr (Position).Pfn := Value;
 260    end CPP_Set_Prim_Op_Address;
 261
 262    -----------------------
 263    -- CPP_Set_RC_Offset --
 264    -----------------------
 265
 266    procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is
 267       pragma Warnings (Off, T);
 268       pragma Warnings (Off, Value);
 269
 270    begin
 271       null;
 272    end CPP_Set_RC_Offset;
 273
 274    -------------------------------
 275    -- CPP_Set_Remotely_Callable --
 276    -------------------------------
 277
 278    procedure CPP_Set_Remotely_Callable (T : Vtable_Ptr; Value : Boolean) is
 279       pragma Warnings (Off, T);
 280       pragma Warnings (Off, Value);
 281
 282    begin
 283       null;
 284    end CPP_Set_Remotely_Callable;
 285
 286    -----------------
 287    -- CPP_Set_TSD --
 288    -----------------
 289
 290    procedure CPP_Set_TSD (T : Vtable_Ptr; Value : Address) is
 291    begin
 292       T.TSD := To_Type_Specific_Data_Ptr (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 := T.TSD.Expanded_Name;
 321
 322    begin
 323       return Result (1 .. Length (Result));
 324    end Expanded_Name;
 325
 326    ------------------
 327    -- External_Tag --
 328    ------------------
 329
 330    function External_Tag (T : Vtable_Ptr) return String is
 331       Result : constant Cstring_Ptr := T.TSD.External_Tag;
 332
 333    begin
 334       return Result (1 .. Length (Result));
 335    end External_Tag;
 336
 337    ------------
 338    -- Length --
 339    ------------
 340
 341    function Length (Str : Cstring_Ptr) return Natural is
 342       Len : Integer := 1;
 343
 344    begin
 345       while Str (Len) /= ASCII.Nul loop
 346          Len := Len + 1;
 347       end loop;
 348
 349       return Len - 1;
 350    end Length;
 351 end Interfaces.CPP;