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