1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- I N T E R F A C E S . C P P --
10 -- Copyright (C) 2000-2002, Free Software Foundation, Inc. --
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. --
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. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- Extensive contributions were provided by Ada Core Technologies Inc. --
33 ------------------------------------------------------------------------------
35 -- This is the OpenVMS/Alpha DEC C++ (cxx) version of this package.
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;
42 package body Interfaces.CPP is
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);
49 type Type_Specific_Data is record
51 Expanded_Name : Cstring_Ptr;
52 External_Tag : Cstring_Ptr;
54 Ancestor_Tags : Tag_Table (Natural);
57 type Vtable_Entry is record
61 type Type_Specific_Data_Ptr is access all Type_Specific_Data;
62 type Vtable_Entry_Array is array (Positive range <>) of Vtable_Entry;
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. ???
71 --------------------------------------------------------
72 -- Unchecked Conversions for Tag, Vtable_Ptr, and TSD --
73 --------------------------------------------------------
75 function To_Type_Specific_Data_Ptr is
76 new Unchecked_Conversion (Address, Type_Specific_Data_Ptr);
78 function To_Address is
79 new Unchecked_Conversion (Type_Specific_Data_Ptr, Address);
81 ---------------------------------------------
82 -- Unchecked Conversions for String Fields --
83 ---------------------------------------------
85 function To_Cstring_Ptr is
86 new Unchecked_Conversion (Address, Cstring_Ptr);
88 function To_Address is
89 new Unchecked_Conversion (Cstring_Ptr, Address);
91 -----------------------
92 -- Local Subprograms --
93 -----------------------
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).
103 function Displaced_This
104 (Current_This : System.Address;
107 return System.Address
111 -- + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1);
114 -----------------------
115 -- CPP_CW_Membership --
116 -----------------------
118 function CPP_CW_Membership
119 (Obj_Tag : Vtable_Ptr;
120 Typ_Tag : Vtable_Ptr)
123 Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth;
125 return Pos >= 0 and then Obj_Tag.TSD.Ancestor_Tags (Pos) = Typ_Tag;
126 end CPP_CW_Membership;
128 ---------------------------
129 -- CPP_Get_Expanded_Name --
130 ---------------------------
132 function CPP_Get_Expanded_Name (T : Vtable_Ptr) return Address is
134 return To_Address (T.TSD.Expanded_Name);
135 end CPP_Get_Expanded_Name;
137 --------------------------
138 -- CPP_Get_External_Tag --
139 --------------------------
141 function CPP_Get_External_Tag (T : Vtable_Ptr) return Address is
143 return To_Address (T.TSD.External_Tag);
144 end CPP_Get_External_Tag;
146 -------------------------------
147 -- CPP_Get_Inheritance_Depth --
148 -------------------------------
150 function CPP_Get_Inheritance_Depth (T : Vtable_Ptr) return Natural is
153 end CPP_Get_Inheritance_Depth;
155 -------------------------
156 -- CPP_Get_Prim_Op_Address --
157 -------------------------
159 function CPP_Get_Prim_Op_Address
164 return T.Prims_Ptr (Position).Pfn;
165 end CPP_Get_Prim_Op_Address;
167 -------------------------------
168 -- CPP_Get_Remotely_Callable --
169 -------------------------------
171 function CPP_Get_Remotely_Callable (T : Vtable_Ptr) return Boolean is
174 end CPP_Get_Remotely_Callable;
180 function CPP_Get_TSD (T : Vtable_Ptr) return Address is
182 return To_Address (T.TSD);
189 procedure CPP_Inherit_DT
192 Entry_Count : Natural)
195 if Old_T /= null then
196 New_T.Prims_Ptr (1 .. Entry_Count)
197 := Old_T.Prims_Ptr (1 .. Entry_Count);
201 ---------------------
202 -- CPP_Inherit_TSD --
203 ---------------------
205 procedure CPP_Inherit_TSD
207 New_Tag : Vtable_Ptr)
209 TSD : constant Type_Specific_Data_Ptr
210 := To_Type_Specific_Data_Ptr (Old_TSD);
212 New_TSD : Type_Specific_Data renames New_Tag.TSD.all;
216 New_TSD.Idepth := TSD.Idepth + 1;
217 New_TSD.Ancestor_Tags (1 .. New_TSD.Idepth)
218 := TSD.Ancestor_Tags (0 .. TSD.Idepth);
223 New_TSD.Ancestor_Tags (0) := New_Tag;
226 ---------------------------
227 -- CPP_Set_Expanded_Name --
228 ---------------------------
230 procedure CPP_Set_Expanded_Name (T : Vtable_Ptr; Value : Address) is
232 T.TSD.Expanded_Name := To_Cstring_Ptr (Value);
233 end CPP_Set_Expanded_Name;
235 --------------------------
236 -- CPP_Set_External_Tag --
237 --------------------------
239 procedure CPP_Set_External_Tag (T : Vtable_Ptr; Value : Address) is
241 T.TSD.External_Tag := To_Cstring_Ptr (Value);
242 end CPP_Set_External_Tag;
244 -------------------------------
245 -- CPP_Set_Inheritance_Depth --
246 -------------------------------
248 procedure CPP_Set_Inheritance_Depth
253 T.TSD.Idepth := Value;
254 end CPP_Set_Inheritance_Depth;
256 -----------------------------
257 -- CPP_Set_Prim_Op_Address --
258 -----------------------------
260 procedure CPP_Set_Prim_Op_Address
266 T.Prims_Ptr (Position).Pfn := Value;
267 end CPP_Set_Prim_Op_Address;
269 -------------------------------
270 -- CPP_Set_Remotely_Callable --
271 -------------------------------
273 procedure CPP_Set_Remotely_Callable (T : Vtable_Ptr; Value : Boolean) is
276 end CPP_Set_Remotely_Callable;
282 procedure CPP_Set_TSD (T : Vtable_Ptr; Value : Address) is
284 T.TSD := To_Type_Specific_Data_Ptr (Value);
291 function Expanded_Name (T : Vtable_Ptr) return String is
292 Result : Cstring_Ptr := T.TSD.Expanded_Name;
295 return Result (1 .. Length (Result));
302 function External_Tag (T : Vtable_Ptr) return String is
303 Result : Cstring_Ptr := T.TSD.External_Tag;
306 return Result (1 .. Length (Result));
313 function Length (Str : Cstring_Ptr) return Natural is
317 while Str (Len) /= ASCII.Nul loop
324 procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is
327 end CPP_Set_RC_Offset;
329 function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is
332 end CPP_Get_RC_Offset;