1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- I N T E R F A C E S . C P P --
9 -- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
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. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with Ada
.Tags
; use Ada
.Tags
;
35 with System
; use System
;
36 with System
.Storage_Elements
; use System
.Storage_Elements
;
37 with Unchecked_Conversion
;
39 package body Interfaces
.CPP
is
41 -- The declarations below need (extensive) comments ???
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
;
64 Prims_Ptr
: Vtable_Entry_Array
(Positive);
65 TSD
: Type_Specific_Data_Ptr
;
68 --------------------------------------------------------
69 -- Unchecked Conversions for Tag, Vtable_Ptr, and TSD --
70 --------------------------------------------------------
72 function To_Type_Specific_Data_Ptr
is
73 new Unchecked_Conversion
(Address
, Type_Specific_Data_Ptr
);
75 function To_Address
is
76 new Unchecked_Conversion
(Type_Specific_Data_Ptr
, Address
);
78 ---------------------------------------------
79 -- Unchecked Conversions for String Fields --
80 ---------------------------------------------
82 function To_Cstring_Ptr
is
83 new Unchecked_Conversion
(Address
, Cstring_Ptr
);
85 function To_Address
is
86 new Unchecked_Conversion
(Cstring_Ptr
, Address
);
88 -----------------------
89 -- Local Subprograms --
90 -----------------------
92 function Length
(Str
: Cstring_Ptr
) return Natural;
93 -- Length of string represented by the given pointer (treating the
94 -- string as a C-style string, which is Nul terminated).
96 -----------------------
97 -- CPP_CW_Membership --
98 -----------------------
100 function CPP_CW_Membership
101 (Obj_Tag
: Vtable_Ptr
;
102 Typ_Tag
: Vtable_Ptr
) return Boolean
104 Pos
: constant Integer := Obj_Tag
.TSD
.Idepth
- Typ_Tag
.TSD
.Idepth
;
106 return Pos
>= 0 and then Obj_Tag
.TSD
.Ancestor_Tags
(Pos
) = Typ_Tag
;
107 end CPP_CW_Membership
;
109 ---------------------------
110 -- CPP_Get_Expanded_Name --
111 ---------------------------
113 function CPP_Get_Expanded_Name
(T
: Vtable_Ptr
) return Address
is
115 return To_Address
(T
.TSD
.Expanded_Name
);
116 end CPP_Get_Expanded_Name
;
118 --------------------------
119 -- CPP_Get_External_Tag --
120 --------------------------
122 function CPP_Get_External_Tag
(T
: Vtable_Ptr
) return Address
is
124 return To_Address
(T
.TSD
.External_Tag
);
125 end CPP_Get_External_Tag
;
127 -------------------------------
128 -- CPP_Get_Inheritance_Depth --
129 -------------------------------
131 function CPP_Get_Inheritance_Depth
(T
: Vtable_Ptr
) return Natural is
134 end CPP_Get_Inheritance_Depth
;
136 -------------------------
137 -- CPP_Get_Prim_Op_Address --
138 -------------------------
140 function CPP_Get_Prim_Op_Address
142 Position
: Positive) return Address
145 return T
.Prims_Ptr
(Position
).Pfn
;
146 end CPP_Get_Prim_Op_Address
;
148 -----------------------
149 -- CPP_Get_RC_Offset --
150 -----------------------
152 function CPP_Get_RC_Offset
(T
: Vtable_Ptr
) return SSE
.Storage_Offset
is
153 pragma Warnings
(Off
, T
);
156 end CPP_Get_RC_Offset
;
158 -------------------------------
159 -- CPP_Get_Remotely_Callable --
160 -------------------------------
162 function CPP_Get_Remotely_Callable
(T
: Vtable_Ptr
) return Boolean is
163 pragma Warnings
(Off
, T
);
166 end CPP_Get_Remotely_Callable
;
172 function CPP_Get_TSD
(T
: Vtable_Ptr
) return Address
is
174 return To_Address
(T
.TSD
);
181 procedure CPP_Inherit_DT
184 Entry_Count
: Natural)
187 if Old_T
/= null then
188 New_T
.Prims_Ptr
(1 .. Entry_Count
)
189 := Old_T
.Prims_Ptr
(1 .. Entry_Count
);
193 ---------------------
194 -- CPP_Inherit_TSD --
195 ---------------------
197 procedure CPP_Inherit_TSD
199 New_Tag
: Vtable_Ptr
)
201 TSD
: constant Type_Specific_Data_Ptr
:=
202 To_Type_Specific_Data_Ptr
(Old_TSD
);
204 New_TSD
: Type_Specific_Data
renames New_Tag
.TSD
.all;
208 New_TSD
.Idepth
:= TSD
.Idepth
+ 1;
209 New_TSD
.Ancestor_Tags
(1 .. New_TSD
.Idepth
)
210 := TSD
.Ancestor_Tags
(0 .. TSD
.Idepth
);
215 New_TSD
.Ancestor_Tags
(0) := New_Tag
;
218 ---------------------------
219 -- CPP_Set_Expanded_Name --
220 ---------------------------
222 procedure CPP_Set_Expanded_Name
(T
: Vtable_Ptr
; Value
: Address
) is
224 T
.TSD
.Expanded_Name
:= To_Cstring_Ptr
(Value
);
225 end CPP_Set_Expanded_Name
;
227 --------------------------
228 -- CPP_Set_External_Tag --
229 --------------------------
231 procedure CPP_Set_External_Tag
(T
: Vtable_Ptr
; Value
: Address
) is
233 T
.TSD
.External_Tag
:= To_Cstring_Ptr
(Value
);
234 end CPP_Set_External_Tag
;
236 -------------------------------
237 -- CPP_Set_Inheritance_Depth --
238 -------------------------------
240 procedure CPP_Set_Inheritance_Depth
245 T
.TSD
.Idepth
:= Value
;
246 end CPP_Set_Inheritance_Depth
;
248 -----------------------------
249 -- CPP_Set_Prim_Op_Address --
250 -----------------------------
252 procedure CPP_Set_Prim_Op_Address
258 T
.Prims_Ptr
(Position
).Pfn
:= Value
;
259 end CPP_Set_Prim_Op_Address
;
261 -----------------------
262 -- CPP_Set_RC_Offset --
263 -----------------------
265 procedure CPP_Set_RC_Offset
(T
: Vtable_Ptr
; Value
: SSE
.Storage_Offset
) is
266 pragma Warnings
(Off
, T
);
267 pragma Warnings
(Off
, Value
);
270 end CPP_Set_RC_Offset
;
272 -------------------------------
273 -- CPP_Set_Remotely_Callable --
274 -------------------------------
276 procedure CPP_Set_Remotely_Callable
(T
: Vtable_Ptr
; Value
: Boolean) is
277 pragma Warnings
(Off
, T
);
278 pragma Warnings
(Off
, Value
);
281 end CPP_Set_Remotely_Callable
;
287 procedure CPP_Set_TSD
(T
: Vtable_Ptr
; Value
: Address
) is
289 T
.TSD
:= To_Type_Specific_Data_Ptr
(Value
);
296 function Displaced_This
297 (Current_This
: System
.Address
;
300 return System
.Address
302 pragma Warnings
(Off
, Vptr
);
303 pragma Warnings
(Off
, Position
);
308 -- why is the following here commented out ???
309 -- + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1);
316 function Expanded_Name
(T
: Vtable_Ptr
) return String is
317 Result
: constant Cstring_Ptr
:= T
.TSD
.Expanded_Name
;
319 return Result
(1 .. Length
(Result
));
326 function External_Tag
(T
: Vtable_Ptr
) return String is
327 Result
: constant Cstring_Ptr
:= T
.TSD
.External_Tag
;
329 return Result
(1 .. Length
(Result
));
336 function Length
(Str
: Cstring_Ptr
) return Natural is
340 while Str
(Len
) /= ASCII
.Nul
loop