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