1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- I N T E R F A C E S . C P P --
10 -- Copyright (C) 1992-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 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
35 with Ada
.Tags
; use Ada
.Tags
;
36 with Interfaces
.C
; use Interfaces
.C
;
37 with System
; use System
;
38 with System
.Storage_Elements
; use System
.Storage_Elements
;
39 with Unchecked_Conversion
;
41 package body Interfaces
.CPP
is
43 subtype Cstring
is String (Positive);
44 type Cstring_Ptr
is access all Cstring
;
45 type Tag_Table
is array (Natural range <>) of Vtable_Ptr
;
46 pragma Suppress_Initialization
(Tag_Table
);
48 type Type_Specific_Data
is record
50 Expanded_Name
: Cstring_Ptr
;
51 External_Tag
: Cstring_Ptr
;
53 Ancestor_Tags
: Tag_Table
(Natural);
56 type Vtable_Entry
is record
60 type Type_Specific_Data_Ptr
is access all Type_Specific_Data
;
61 type Vtable_Entry_Array
is array (Positive range <>) of Vtable_Entry
;
66 TSD
: Type_Specific_Data_Ptr
;
67 Prims_Ptr
: Vtable_Entry_Array
(Positive);
70 --------------------------------------------------------
71 -- Unchecked Conversions for Tag, Vtable_Ptr, and TSD --
72 --------------------------------------------------------
74 function To_Type_Specific_Data_Ptr
is
75 new Unchecked_Conversion
(Address
, Type_Specific_Data_Ptr
);
77 function To_Address
is
78 new Unchecked_Conversion
(Type_Specific_Data_Ptr
, Address
);
80 ---------------------------------------------
81 -- Unchecked Conversions for String Fields --
82 ---------------------------------------------
84 function To_Cstring_Ptr
is
85 new Unchecked_Conversion
(Address
, Cstring_Ptr
);
87 function To_Address
is
88 new Unchecked_Conversion
(Cstring_Ptr
, Address
);
90 -----------------------
91 -- Local Subprograms --
92 -----------------------
94 function Length
(Str
: Cstring_Ptr
) return Natural;
95 -- Length of string represented by the given pointer (treating the
96 -- string as a C-style string, which is Nul terminated).
98 -----------------------
99 -- CPP_CW_Membership --
100 -----------------------
102 function CPP_CW_Membership
103 (Obj_Tag
: Vtable_Ptr
;
104 Typ_Tag
: Vtable_Ptr
)
107 Pos
: constant Integer := Obj_Tag
.TSD
.Idepth
- Typ_Tag
.TSD
.Idepth
;
109 return Pos
>= 0 and then Obj_Tag
.TSD
.Ancestor_Tags
(Pos
) = Typ_Tag
;
110 end CPP_CW_Membership
;
112 ---------------------------
113 -- CPP_Get_Expanded_Name --
114 ---------------------------
116 function CPP_Get_Expanded_Name
(T
: Vtable_Ptr
) return Address
is
118 return To_Address
(T
.TSD
.Expanded_Name
);
119 end CPP_Get_Expanded_Name
;
121 --------------------------
122 -- CPP_Get_External_Tag --
123 --------------------------
125 function CPP_Get_External_Tag
(T
: Vtable_Ptr
) return Address
is
127 return To_Address
(T
.TSD
.External_Tag
);
128 end CPP_Get_External_Tag
;
130 -------------------------------
131 -- CPP_Get_Inheritance_Depth --
132 -------------------------------
134 function CPP_Get_Inheritance_Depth
(T
: Vtable_Ptr
) return Natural is
137 end CPP_Get_Inheritance_Depth
;
139 -------------------------
140 -- CPP_Get_Prim_Op_Address --
141 -------------------------
143 function CPP_Get_Prim_Op_Address
148 return T
.Prims_Ptr
(Position
).Pfn
;
149 end CPP_Get_Prim_Op_Address
;
151 -----------------------
152 -- CPP_Get_RC_Offset --
153 -----------------------
155 function CPP_Get_RC_Offset
(T
: Vtable_Ptr
) return SSE
.Storage_Offset
is
156 pragma Warnings
(Off
, T
);
160 end CPP_Get_RC_Offset
;
162 -------------------------------
163 -- CPP_Get_Remotely_Callable --
164 -------------------------------
166 function CPP_Get_Remotely_Callable
(T
: Vtable_Ptr
) return Boolean is
167 pragma Warnings
(Off
, T
);
171 end CPP_Get_Remotely_Callable
;
177 function CPP_Get_TSD
(T
: Vtable_Ptr
) return Address
is
179 return To_Address
(T
.TSD
);
186 procedure CPP_Inherit_DT
189 Entry_Count
: Natural)
192 if Old_T
/= null then
193 New_T
.Prims_Ptr
(1 .. Entry_Count
)
194 := Old_T
.Prims_Ptr
(1 .. Entry_Count
);
198 ---------------------
199 -- CPP_Inherit_TSD --
200 ---------------------
202 procedure CPP_Inherit_TSD
204 New_Tag
: Vtable_Ptr
)
206 TSD
: constant Type_Specific_Data_Ptr
207 := To_Type_Specific_Data_Ptr
(Old_TSD
);
209 New_TSD
: Type_Specific_Data
renames New_Tag
.TSD
.all;
213 New_TSD
.Idepth
:= TSD
.Idepth
+ 1;
214 New_TSD
.Ancestor_Tags
(1 .. New_TSD
.Idepth
)
215 := TSD
.Ancestor_Tags
(0 .. TSD
.Idepth
);
220 New_TSD
.Ancestor_Tags
(0) := New_Tag
;
223 ---------------------------
224 -- CPP_Set_Expanded_Name --
225 ---------------------------
227 procedure CPP_Set_Expanded_Name
(T
: Vtable_Ptr
; Value
: Address
) is
229 T
.TSD
.Expanded_Name
:= To_Cstring_Ptr
(Value
);
230 end CPP_Set_Expanded_Name
;
232 --------------------------
233 -- CPP_Set_External_Tag --
234 --------------------------
236 procedure CPP_Set_External_Tag
(T
: Vtable_Ptr
; Value
: Address
) is
238 T
.TSD
.External_Tag
:= To_Cstring_Ptr
(Value
);
239 end CPP_Set_External_Tag
;
241 -------------------------------
242 -- CPP_Set_Inheritance_Depth --
243 -------------------------------
245 procedure CPP_Set_Inheritance_Depth
250 T
.TSD
.Idepth
:= Value
;
251 end CPP_Set_Inheritance_Depth
;
253 -----------------------------
254 -- CPP_Set_Prim_Op_Address --
255 -----------------------------
257 procedure CPP_Set_Prim_Op_Address
263 T
.Prims_Ptr
(Position
).Pfn
:= Value
;
264 end CPP_Set_Prim_Op_Address
;
266 -----------------------
267 -- CPP_Set_RC_Offset --
268 -----------------------
270 procedure CPP_Set_RC_Offset
(T
: Vtable_Ptr
; Value
: SSE
.Storage_Offset
) is
271 pragma Warnings
(Off
, T
);
272 pragma Warnings
(Off
, Value
);
276 end CPP_Set_RC_Offset
;
278 -------------------------------
279 -- CPP_Set_Remotely_Callable --
280 -------------------------------
282 procedure CPP_Set_Remotely_Callable
(T
: Vtable_Ptr
; Value
: Boolean) is
283 pragma Warnings
(Off
, T
);
284 pragma Warnings
(Off
, Value
);
288 end CPP_Set_Remotely_Callable
;
294 procedure CPP_Set_TSD
(T
: Vtable_Ptr
; Value
: Address
) is
296 T
.TSD
:= To_Type_Specific_Data_Ptr
(Value
);
303 function Displaced_This
304 (Current_This
: System
.Address
;
307 return System
.Address
309 pragma Warnings
(Off
, Vptr
);
310 pragma Warnings
(Off
, Position
);
315 -- why is the following here commented out ???
316 -- + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1);
323 function Expanded_Name
(T
: Vtable_Ptr
) return String is
324 Result
: Cstring_Ptr
:= T
.TSD
.Expanded_Name
;
327 return Result
(1 .. Length
(Result
));
334 function External_Tag
(T
: Vtable_Ptr
) return String is
335 Result
: Cstring_Ptr
:= T
.TSD
.External_Tag
;
338 return Result
(1 .. Length
(Result
));
345 function Length
(Str
: Cstring_Ptr
) return Natural is
349 while Str
(Len
) /= ASCII
.Nul
loop