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 --                            $Revision: 1.19 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 with Ada.Tags;                use Ada.Tags;
  37 with Interfaces.C;            use Interfaces.C;
  38 with System;                  use System;
  39 with System.Storage_Elements; use System.Storage_Elements;
  40 with Unchecked_Conversion;
  41
  42 package body Interfaces.CPP is
  43
  44    subtype Cstring is String (Positive);
  45    type Cstring_Ptr is access all Cstring;
  46    type Tag_Table is array (Natural range <>) of Vtable_Ptr;
  47    pragma Suppress_Initialization (Tag_Table);
  48
  49    type Type_Specific_Data is record
  50       Idepth        : Natural;
  51       Expanded_Name : Cstring_Ptr;
  52       External_Tag  : Cstring_Ptr;
  53       HT_Link       : Tag;
  54       Ancestor_Tags : Tag_Table (Natural);
  55    end record;
  56
  57    type Vtable_Entry is record
  58      Pfn    : System.Address;
  59    end record;
  60
  61    type Type_Specific_Data_Ptr is access all Type_Specific_Data;
  62    type Vtable_Entry_Array is array (Positive range <>) of Vtable_Entry;
  63
  64    type VTable is record
  65       Unused1   : C.short;
  66       Unused2   : C.short;
  67       TSD       : Type_Specific_Data_Ptr;
  68       Prims_Ptr : Vtable_Entry_Array (Positive);
  69    end record;
  70
  71    --------------------------------------------------------
  72    -- Unchecked Conversions for Tag, Vtable_Ptr, and TSD --
  73    --------------------------------------------------------
  74
  75    function To_Type_Specific_Data_Ptr is
  76      new Unchecked_Conversion (Address, Type_Specific_Data_Ptr);
  77
  78    function To_Address is new Unchecked_Conversion (Vtable_Ptr, Address);
  79    function To_Address is
  80      new Unchecked_Conversion (Type_Specific_Data_Ptr, Address);
  81
  82    function To_Vtable_Ptr is new Unchecked_Conversion (Tag, Vtable_Ptr);
  83    function To_Tag is new Unchecked_Conversion (Vtable_Ptr, Tag);
  84
  85    ---------------------------------------------
  86    -- Unchecked Conversions for String Fields --
  87    ---------------------------------------------
  88
  89    function To_Cstring_Ptr is
  90      new Unchecked_Conversion (Address, Cstring_Ptr);
  91
  92    function To_Address is
  93      new Unchecked_Conversion (Cstring_Ptr, Address);
  94
  95    -----------------------
  96    -- Local Subprograms --
  97    -----------------------
  98
  99    function Length (Str : Cstring_Ptr) return Natural;
 100    --  Length of string represented by the given pointer (treating the
 101    --  string as a C-style string, which is Nul terminated).
 102
 103    -----------------------
 104    -- CPP_CW_Membership --
 105    -----------------------
 106
 107    function CPP_CW_Membership
 108      (Obj_Tag : Vtable_Ptr;
 109       Typ_Tag : Vtable_Ptr)
 110       return Boolean
 111    is
 112       Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth;
 113    begin
 114       return Pos >= 0 and then Obj_Tag.TSD.Ancestor_Tags (Pos) = Typ_Tag;
 115    end CPP_CW_Membership;
 116
 117    ---------------------------
 118    -- CPP_Get_Expanded_Name --
 119    ---------------------------
 120
 121    function CPP_Get_Expanded_Name (T : Vtable_Ptr) return Address is
 122    begin
 123       return To_Address (T.TSD.Expanded_Name);
 124    end CPP_Get_Expanded_Name;
 125
 126    --------------------------
 127    -- CPP_Get_External_Tag --
 128    --------------------------
 129
 130    function CPP_Get_External_Tag (T : Vtable_Ptr) return Address is
 131    begin
 132       return To_Address (T.TSD.External_Tag);
 133    end CPP_Get_External_Tag;
 134
 135    -------------------------------
 136    -- CPP_Get_Inheritance_Depth --
 137    -------------------------------
 138
 139    function CPP_Get_Inheritance_Depth (T : Vtable_Ptr) return Natural is
 140    begin
 141       return T.TSD.Idepth;
 142    end CPP_Get_Inheritance_Depth;
 143
 144    -------------------------
 145    -- CPP_Get_Prim_Op_Address --
 146    -------------------------
 147
 148    function CPP_Get_Prim_Op_Address
 149      (T        : Vtable_Ptr;
 150       Position : Positive)
 151       return Address is
 152    begin
 153       return T.Prims_Ptr (Position).Pfn;
 154    end CPP_Get_Prim_Op_Address;
 155
 156    -----------------------
 157    -- CPP_Get_RC_Offset --
 158    -----------------------
 159
 160    function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is
 161    begin
 162       return 0;
 163    end CPP_Get_RC_Offset;
 164
 165    -------------------------------
 166    -- CPP_Get_Remotely_Callable --
 167    -------------------------------
 168
 169    function CPP_Get_Remotely_Callable (T : Vtable_Ptr) return Boolean is
 170    begin
 171       return True;
 172    end CPP_Get_Remotely_Callable;
 173
 174    -----------------
 175    -- CPP_Get_TSD --
 176    -----------------
 177
 178    function CPP_Get_TSD  (T : Vtable_Ptr) return Address is
 179    begin
 180       return To_Address (T.TSD);
 181    end CPP_Get_TSD;
 182
 183    --------------------
 184    -- CPP_Inherit_DT --
 185    --------------------
 186
 187    procedure CPP_Inherit_DT
 188     (Old_T   : Vtable_Ptr;
 189      New_T   : Vtable_Ptr;
 190      Entry_Count : Natural)
 191    is
 192    begin
 193       if Old_T /= null then
 194          New_T.Prims_Ptr (1 .. Entry_Count)
 195            := Old_T.Prims_Ptr (1 .. Entry_Count);
 196       end if;
 197    end CPP_Inherit_DT;
 198
 199    ---------------------
 200    -- CPP_Inherit_TSD --
 201    ---------------------
 202
 203    procedure CPP_Inherit_TSD
 204      (Old_TSD : Address;
 205       New_Tag : Vtable_Ptr)
 206    is
 207       TSD : constant Type_Specific_Data_Ptr
 208         := To_Type_Specific_Data_Ptr (Old_TSD);
 209
 210       New_TSD : Type_Specific_Data renames New_Tag.TSD.all;
 211
 212    begin
 213       if TSD /= null then
 214          New_TSD.Idepth := TSD.Idepth + 1;
 215          New_TSD.Ancestor_Tags (1 .. New_TSD.Idepth)
 216            := TSD.Ancestor_Tags (0 .. TSD.Idepth);
 217       else
 218          New_TSD.Idepth := 0;
 219       end if;
 220
 221       New_TSD.Ancestor_Tags (0) := New_Tag;
 222    end CPP_Inherit_TSD;
 223
 224    ---------------------------
 225    -- CPP_Set_Expanded_Name --
 226    ---------------------------
 227
 228    procedure CPP_Set_Expanded_Name (T : Vtable_Ptr; Value : Address) is
 229    begin
 230       T.TSD.Expanded_Name := To_Cstring_Ptr (Value);
 231    end CPP_Set_Expanded_Name;
 232
 233    --------------------------
 234    -- CPP_Set_External_Tag --
 235    --------------------------
 236
 237    procedure CPP_Set_External_Tag (T : Vtable_Ptr; Value : Address) is
 238    begin
 239       T.TSD.External_Tag := To_Cstring_Ptr (Value);
 240    end CPP_Set_External_Tag;
 241
 242    -------------------------------
 243    -- CPP_Set_Inheritance_Depth --
 244    -------------------------------
 245
 246    procedure CPP_Set_Inheritance_Depth
 247      (T     : Vtable_Ptr;
 248       Value : Natural)
 249    is
 250    begin
 251       T.TSD.Idepth := Value;
 252    end CPP_Set_Inheritance_Depth;
 253
 254    -----------------------------
 255    -- CPP_Set_Prim_Op_Address --
 256    -----------------------------
 257
 258    procedure CPP_Set_Prim_Op_Address
 259      (T        : Vtable_Ptr;
 260       Position : Positive;
 261       Value    : Address)
 262    is
 263    begin
 264       T.Prims_Ptr (Position).Pfn := Value;
 265    end CPP_Set_Prim_Op_Address;
 266
 267    -----------------------
 268    -- CPP_Set_RC_Offset --
 269    -----------------------
 270
 271    procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is
 272    begin
 273       null;
 274    end CPP_Set_RC_Offset;
 275
 276    -------------------------------
 277    -- CPP_Set_Remotely_Callable --
 278    -------------------------------
 279
 280    procedure CPP_Set_Remotely_Callable (T : Vtable_Ptr; Value : Boolean) is
 281    begin
 282       null;
 283    end CPP_Set_Remotely_Callable;
 284
 285    -----------------
 286    -- CPP_Set_TSD --
 287    -----------------
 288
 289    procedure CPP_Set_TSD (T : Vtable_Ptr; Value : Address) is
 290    begin
 291       T.TSD := To_Type_Specific_Data_Ptr (Value);
 292    end CPP_Set_TSD;
 293
 294    --------------------
 295    -- Displaced_This --
 296    --------------------
 297
 298    function Displaced_This
 299     (Current_This : System.Address;
 300      Vptr         : Vtable_Ptr;
 301      Position     : Positive)
 302      return         System.Address
 303    is
 304    begin
 305       return Current_This;
 306
 307       --  why is the following here commented out ???
 308       --  + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1);
 309    end Displaced_This;
 310
 311    -------------------
 312    -- Expanded_Name --
 313    -------------------
 314
 315    function Expanded_Name (T : Vtable_Ptr) return String is
 316       Result : Cstring_Ptr := T.TSD.Expanded_Name;
 317
 318    begin
 319       return Result (1 .. Length (Result));
 320    end Expanded_Name;
 321
 322    ------------------
 323    -- External_Tag --
 324    ------------------
 325
 326    function External_Tag (T : Vtable_Ptr) return String is
 327       Result : Cstring_Ptr := T.TSD.External_Tag;
 328
 329    begin
 330       return Result (1 .. Length (Result));
 331    end External_Tag;
 332
 333    ------------
 334    -- Length --
 335    ------------
 336
 337    function Length (Str : Cstring_Ptr) return Natural is
 338       Len : Integer := 1;
 339
 340    begin
 341       while Str (Len) /= ASCII.Nul loop
 342          Len := Len + 1;
 343       end loop;
 344
 345       return Len - 1;
 346    end Length;
 347 end Interfaces.CPP;