]>
Commit | Line | Data |
---|---|---|
d23b8f57 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
758c442c | 3 | -- GNAT RUN-TIME COMPONENTS -- |
d23b8f57 RK |
4 | -- -- |
5 | -- A D A . T A G S -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
748086b7 | 9 | -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- |
d23b8f57 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- -- | |
748086b7 | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
d23b8f57 RK |
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 -- | |
748086b7 | 16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
d23b8f57 | 17 | -- -- |
748086b7 JJ |
18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- |
19 | -- additional permissions described in the GCC Runtime Library Exception, -- | |
20 | -- version 3.1, as published by the Free Software Foundation. -- | |
21 | -- -- | |
22 | -- You should have received a copy of the GNU General Public License and -- | |
23 | -- a copy of the GCC Runtime Library Exception along with this program; -- | |
24 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- | |
25 | -- <http://www.gnu.org/licenses/>. -- | |
d23b8f57 RK |
26 | -- -- |
27 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 28 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
d23b8f57 RK |
29 | -- -- |
30 | ------------------------------------------------------------------------------ | |
31 | ||
32 | with Ada.Exceptions; | |
5e1527bd | 33 | with Ada.Unchecked_Conversion; |
fbf5a39b | 34 | with System.HTable; |
758c442c | 35 | with System.Storage_Elements; use System.Storage_Elements; |
a05e99a2 JM |
36 | with System.WCh_Con; use System.WCh_Con; |
37 | with System.WCh_StW; use System.WCh_StW; | |
fbf5a39b | 38 | |
fbf5a39b | 39 | pragma Elaborate_All (System.HTable); |
d23b8f57 RK |
40 | |
41 | package body Ada.Tags is | |
42 | ||
d0dd5209 JM |
43 | ----------------------- |
44 | -- Local Subprograms -- | |
45 | ----------------------- | |
46 | ||
47 | function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean; | |
48 | -- Given the tag of an object and the tag associated to a type, return | |
49 | -- true if Obj is in Typ'Class. | |
f4d379b8 | 50 | |
d0dd5209 JM |
51 | function Get_External_Tag (T : Tag) return System.Address; |
52 | -- Returns address of a null terminated string containing the external name | |
f4d379b8 | 53 | |
d0dd5209 JM |
54 | function Is_Primary_DT (T : Tag) return Boolean; |
55 | -- Given a tag returns True if it has the signature of a primary dispatch | |
56 | -- table. This is Inline_Always since it is called from other Inline_ | |
57 | -- Always subprograms where we want no out of line code to be generated. | |
f4d379b8 | 58 | |
d0dd5209 JM |
59 | function Length (Str : Cstring_Ptr) return Natural; |
60 | -- Length of string represented by the given pointer (treating the string | |
61 | -- as a C-style string, which is Nul terminated). | |
f4d379b8 | 62 | |
d0dd5209 JM |
63 | function OSD (T : Tag) return Object_Specific_Data_Ptr; |
64 | -- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table, | |
65 | -- retrieve the address of the record containing the Object Specific | |
66 | -- Data table. | |
f4d379b8 | 67 | |
d0dd5209 JM |
68 | function SSD (T : Tag) return Select_Specific_Data_Ptr; |
69 | -- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, retrieves the | |
70 | -- address of the record containing the Select Specific Data in T's TSD. | |
f4d379b8 | 71 | |
d0dd5209 JM |
72 | pragma Inline_Always (CW_Membership); |
73 | pragma Inline_Always (Get_External_Tag); | |
74 | pragma Inline_Always (Is_Primary_DT); | |
75 | pragma Inline_Always (OSD); | |
76 | pragma Inline_Always (SSD); | |
10b93b2e | 77 | |
5e1527bd | 78 | -- Unchecked conversions |
d23b8f57 | 79 | |
d23b8f57 | 80 | function To_Address is |
8a6a52dc | 81 | new Unchecked_Conversion (Cstring_Ptr, System.Address); |
d23b8f57 | 82 | |
758c442c GD |
83 | function To_Cstring_Ptr is |
84 | new Unchecked_Conversion (System.Address, Cstring_Ptr); | |
85 | ||
5e1527bd | 86 | -- Disable warnings on possible aliasing problem |
d0dd5209 JM |
87 | |
88 | function To_Tag is | |
89 | new Unchecked_Conversion (Integer_Address, Tag); | |
90 | ||
5e1527bd JM |
91 | function To_Addr_Ptr is |
92 | new Ada.Unchecked_Conversion (System.Address, Addr_Ptr); | |
93 | ||
94 | function To_Address is | |
95 | new Ada.Unchecked_Conversion (Tag, System.Address); | |
96 | ||
97 | function To_Dispatch_Table_Ptr is | |
98 | new Ada.Unchecked_Conversion (Tag, Dispatch_Table_Ptr); | |
99 | ||
100 | function To_Dispatch_Table_Ptr is | |
101 | new Ada.Unchecked_Conversion (System.Address, Dispatch_Table_Ptr); | |
102 | ||
103 | function To_Object_Specific_Data_Ptr is | |
104 | new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr); | |
105 | ||
5e1527bd JM |
106 | function To_Tag_Ptr is |
107 | new Ada.Unchecked_Conversion (System.Address, Tag_Ptr); | |
108 | ||
109 | function To_Type_Specific_Data_Ptr is | |
110 | new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr); | |
d0dd5209 | 111 | |
d0dd5209 JM |
112 | ------------------------------- |
113 | -- Inline_Always Subprograms -- | |
114 | ------------------------------- | |
a05e99a2 | 115 | |
d0dd5209 JM |
116 | -- Inline_always subprograms must be placed before their first call to |
117 | -- avoid defeating the frontend inlining mechanism and thus ensure the | |
118 | -- generation of their correct debug info. | |
a05e99a2 | 119 | |
d0dd5209 JM |
120 | ------------------- |
121 | -- CW_Membership -- | |
122 | ------------------- | |
82c80734 | 123 | |
d0dd5209 | 124 | -- Canonical implementation of Classwide Membership corresponding to: |
82c80734 | 125 | |
d0dd5209 | 126 | -- Obj in Typ'Class |
d23b8f57 | 127 | |
d0dd5209 JM |
128 | -- Each dispatch table contains a reference to a table of ancestors (stored |
129 | -- in the first part of the Tags_Table) and a count of the level of | |
130 | -- inheritance "Idepth". | |
f4d379b8 | 131 | |
d0dd5209 JM |
132 | -- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are |
133 | -- contained in the dispatch table referenced by Obj'Tag . Knowing the | |
134 | -- level of inheritance of both types, this can be computed in constant | |
135 | -- time by the formula: | |
136 | ||
137 | -- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth) | |
138 | -- = Typ'tag | |
139 | ||
140 | function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is | |
141 | Obj_TSD_Ptr : constant Addr_Ptr := | |
142 | To_Addr_Ptr (To_Address (Obj_Tag) - DT_Typeinfo_Ptr_Size); | |
143 | Typ_TSD_Ptr : constant Addr_Ptr := | |
144 | To_Addr_Ptr (To_Address (Typ_Tag) - DT_Typeinfo_Ptr_Size); | |
145 | Obj_TSD : constant Type_Specific_Data_Ptr := | |
146 | To_Type_Specific_Data_Ptr (Obj_TSD_Ptr.all); | |
147 | Typ_TSD : constant Type_Specific_Data_Ptr := | |
148 | To_Type_Specific_Data_Ptr (Typ_TSD_Ptr.all); | |
149 | Pos : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth; | |
150 | begin | |
151 | return Pos >= 0 and then Obj_TSD.Tags_Table (Pos) = Typ_Tag; | |
152 | end CW_Membership; | |
153 | ||
154 | ---------------------- | |
155 | -- Get_External_Tag -- | |
156 | ---------------------- | |
82c80734 | 157 | |
d0dd5209 JM |
158 | function Get_External_Tag (T : Tag) return System.Address is |
159 | TSD_Ptr : constant Addr_Ptr := | |
160 | To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); | |
161 | TSD : constant Type_Specific_Data_Ptr := | |
162 | To_Type_Specific_Data_Ptr (TSD_Ptr.all); | |
163 | begin | |
164 | return To_Address (TSD.External_Tag); | |
165 | end Get_External_Tag; | |
bfef8d0d | 166 | |
d0dd5209 JM |
167 | ------------------- |
168 | -- Is_Primary_DT -- | |
169 | ------------------- | |
82c80734 | 170 | |
d0dd5209 JM |
171 | function Is_Primary_DT (T : Tag) return Boolean is |
172 | begin | |
173 | return DT (T).Signature = Primary_DT; | |
174 | end Is_Primary_DT; | |
175 | ||
176 | --------- | |
177 | -- OSD -- | |
178 | --------- | |
179 | ||
180 | function OSD (T : Tag) return Object_Specific_Data_Ptr is | |
181 | OSD_Ptr : constant Addr_Ptr := | |
182 | To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); | |
183 | begin | |
184 | return To_Object_Specific_Data_Ptr (OSD_Ptr.all); | |
185 | end OSD; | |
186 | ||
187 | --------- | |
188 | -- SSD -- | |
189 | --------- | |
190 | ||
191 | function SSD (T : Tag) return Select_Specific_Data_Ptr is | |
192 | TSD_Ptr : constant Addr_Ptr := | |
193 | To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); | |
194 | TSD : constant Type_Specific_Data_Ptr := | |
195 | To_Type_Specific_Data_Ptr (TSD_Ptr.all); | |
196 | begin | |
197 | return TSD.SSD; | |
198 | end SSD; | |
d23b8f57 RK |
199 | |
200 | ------------------------- | |
201 | -- External_Tag_HTable -- | |
202 | ------------------------- | |
203 | ||
204 | type HTable_Headers is range 1 .. 64; | |
205 | ||
82c80734 RD |
206 | -- The following internal package defines the routines used for the |
207 | -- instantiation of a new System.HTable.Static_HTable (see below). See | |
208 | -- spec in g-htable.ads for details of usage. | |
d23b8f57 RK |
209 | |
210 | package HTable_Subprograms is | |
211 | procedure Set_HT_Link (T : Tag; Next : Tag); | |
212 | function Get_HT_Link (T : Tag) return Tag; | |
8a6a52dc AC |
213 | function Hash (F : System.Address) return HTable_Headers; |
214 | function Equal (A, B : System.Address) return Boolean; | |
d23b8f57 RK |
215 | end HTable_Subprograms; |
216 | ||
fbf5a39b | 217 | package External_Tag_HTable is new System.HTable.Static_HTable ( |
d23b8f57 RK |
218 | Header_Num => HTable_Headers, |
219 | Element => Dispatch_Table, | |
220 | Elmt_Ptr => Tag, | |
221 | Null_Ptr => null, | |
222 | Set_Next => HTable_Subprograms.Set_HT_Link, | |
223 | Next => HTable_Subprograms.Get_HT_Link, | |
8a6a52dc | 224 | Key => System.Address, |
d23b8f57 RK |
225 | Get_Key => Get_External_Tag, |
226 | Hash => HTable_Subprograms.Hash, | |
227 | Equal => HTable_Subprograms.Equal); | |
228 | ||
229 | ------------------------ | |
230 | -- HTable_Subprograms -- | |
231 | ------------------------ | |
232 | ||
233 | -- Bodies of routines for hash table instantiation | |
234 | ||
235 | package body HTable_Subprograms is | |
236 | ||
f4d379b8 HK |
237 | ----------- |
238 | -- Equal -- | |
239 | ----------- | |
d23b8f57 | 240 | |
8a6a52dc | 241 | function Equal (A, B : System.Address) return Boolean is |
fbf5a39b AC |
242 | Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A); |
243 | Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B); | |
d23b8f57 | 244 | J : Integer := 1; |
d23b8f57 RK |
245 | begin |
246 | loop | |
247 | if Str1 (J) /= Str2 (J) then | |
248 | return False; | |
d23b8f57 RK |
249 | elsif Str1 (J) = ASCII.NUL then |
250 | return True; | |
d23b8f57 RK |
251 | else |
252 | J := J + 1; | |
253 | end if; | |
254 | end loop; | |
255 | end Equal; | |
256 | ||
257 | ----------------- | |
258 | -- Get_HT_Link -- | |
259 | ----------------- | |
260 | ||
261 | function Get_HT_Link (T : Tag) return Tag is | |
d0dd5209 JM |
262 | TSD_Ptr : constant Addr_Ptr := |
263 | To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); | |
264 | TSD : constant Type_Specific_Data_Ptr := | |
265 | To_Type_Specific_Data_Ptr (TSD_Ptr.all); | |
d23b8f57 | 266 | begin |
6e818918 | 267 | return TSD.HT_Link.all; |
d23b8f57 RK |
268 | end Get_HT_Link; |
269 | ||
270 | ---------- | |
271 | -- Hash -- | |
272 | ---------- | |
273 | ||
8a6a52dc | 274 | function Hash (F : System.Address) return HTable_Headers is |
fbf5a39b AC |
275 | function H is new System.HTable.Hash (HTable_Headers); |
276 | Str : constant Cstring_Ptr := To_Cstring_Ptr (F); | |
d23b8f57 | 277 | Res : constant HTable_Headers := H (Str (1 .. Length (Str))); |
d23b8f57 RK |
278 | begin |
279 | return Res; | |
280 | end Hash; | |
281 | ||
282 | ----------------- | |
283 | -- Set_HT_Link -- | |
284 | ----------------- | |
285 | ||
286 | procedure Set_HT_Link (T : Tag; Next : Tag) is | |
d0dd5209 JM |
287 | TSD_Ptr : constant Addr_Ptr := |
288 | To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); | |
289 | TSD : constant Type_Specific_Data_Ptr := | |
290 | To_Type_Specific_Data_Ptr (TSD_Ptr.all); | |
d23b8f57 | 291 | begin |
6e818918 | 292 | TSD.HT_Link.all := Next; |
d23b8f57 RK |
293 | end Set_HT_Link; |
294 | ||
295 | end HTable_Subprograms; | |
296 | ||
3d6efb77 JM |
297 | ------------------ |
298 | -- Base_Address -- | |
299 | ------------------ | |
300 | ||
301 | function Base_Address (This : System.Address) return System.Address is | |
302 | begin | |
303 | return This - Offset_To_Top (This); | |
304 | end Base_Address; | |
305 | ||
470cd9e9 RD |
306 | -------------------- |
307 | -- Descendant_Tag -- | |
308 | -------------------- | |
309 | ||
310 | function Descendant_Tag (External : String; Ancestor : Tag) return Tag is | |
311 | Int_Tag : constant Tag := Internal_Tag (External); | |
312 | ||
313 | begin | |
314 | if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then | |
315 | raise Tag_Error; | |
316 | end if; | |
317 | ||
318 | return Int_Tag; | |
319 | end Descendant_Tag; | |
320 | ||
4d744221 JM |
321 | -------------- |
322 | -- Displace -- | |
323 | -------------- | |
324 | ||
325 | function Displace | |
326 | (This : System.Address; | |
327 | T : Tag) return System.Address | |
328 | is | |
4d744221 JM |
329 | Iface_Table : Interface_Data_Ptr; |
330 | Obj_Base : System.Address; | |
d0dd5209 JM |
331 | Obj_DT : Dispatch_Table_Ptr; |
332 | Obj_DT_Tag : Tag; | |
4d744221 JM |
333 | |
334 | begin | |
d0dd5209 JM |
335 | if System."=" (This, System.Null_Address) then |
336 | return System.Null_Address; | |
337 | end if; | |
338 | ||
339 | Obj_Base := Base_Address (This); | |
340 | Obj_DT_Tag := To_Tag_Ptr (Obj_Base).all; | |
341 | Obj_DT := DT (To_Tag_Ptr (Obj_Base).all); | |
342 | Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table; | |
4d744221 JM |
343 | |
344 | if Iface_Table /= null then | |
345 | for Id in 1 .. Iface_Table.Nb_Ifaces loop | |
3d6efb77 | 346 | if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then |
a05e99a2 JM |
347 | |
348 | -- Case of Static value of Offset_To_Top | |
349 | ||
3d6efb77 JM |
350 | if Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top then |
351 | Obj_Base := Obj_Base + | |
352 | Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value; | |
a05e99a2 | 353 | |
cd3cd5b1 AC |
354 | -- Otherwise call the function generated by the expander to |
355 | -- provide the value. | |
a05e99a2 JM |
356 | |
357 | else | |
d0dd5209 JM |
358 | Obj_Base := Obj_Base + |
359 | Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func.all | |
360 | (Obj_Base); | |
a05e99a2 JM |
361 | end if; |
362 | ||
4d744221 JM |
363 | return Obj_Base; |
364 | end if; | |
365 | end loop; | |
366 | end if; | |
367 | ||
bfef8d0d JM |
368 | -- Check if T is an immediate ancestor. This is required to handle |
369 | -- conversion of class-wide interfaces to tagged types. | |
370 | ||
d0dd5209 | 371 | if CW_Membership (Obj_DT_Tag, T) then |
bfef8d0d JM |
372 | return Obj_Base; |
373 | end if; | |
374 | ||
4d744221 JM |
375 | -- If the object does not implement the interface we must raise CE |
376 | ||
5e1527bd | 377 | raise Constraint_Error with "invalid interface conversion"; |
4d744221 JM |
378 | end Displace; |
379 | ||
d0dd5209 JM |
380 | -------- |
381 | -- DT -- | |
382 | -------- | |
383 | ||
384 | function DT (T : Tag) return Dispatch_Table_Ptr is | |
385 | Offset : constant SSE.Storage_Offset := | |
386 | To_Dispatch_Table_Ptr (T).Prims_Ptr'Position; | |
387 | begin | |
388 | return To_Dispatch_Table_Ptr (To_Address (T) - Offset); | |
389 | end DT; | |
390 | ||
758c442c GD |
391 | ------------------- |
392 | -- IW_Membership -- | |
393 | ------------------- | |
394 | ||
395 | -- Canonical implementation of Classwide Membership corresponding to: | |
396 | ||
397 | -- Obj in Iface'Class | |
398 | ||
399 | -- Each dispatch table contains a table with the tags of all the | |
400 | -- implemented interfaces. | |
401 | ||
402 | -- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces | |
403 | -- that are contained in the dispatch table referenced by Obj'Tag. | |
404 | ||
f4d379b8 | 405 | function IW_Membership (This : System.Address; T : Tag) return Boolean is |
4d744221 | 406 | Iface_Table : Interface_Data_Ptr; |
4d744221 | 407 | Obj_Base : System.Address; |
d0dd5209 | 408 | Obj_DT : Dispatch_Table_Ptr; |
4d744221 | 409 | Obj_TSD : Type_Specific_Data_Ptr; |
758c442c GD |
410 | |
411 | begin | |
d0dd5209 JM |
412 | Obj_Base := Base_Address (This); |
413 | Obj_DT := DT (To_Tag_Ptr (Obj_Base).all); | |
414 | Obj_TSD := To_Type_Specific_Data_Ptr (Obj_DT.TSD); | |
415 | Iface_Table := Obj_TSD.Interfaces_Table; | |
10b93b2e | 416 | |
4d744221 JM |
417 | if Iface_Table /= null then |
418 | for Id in 1 .. Iface_Table.Nb_Ifaces loop | |
3d6efb77 | 419 | if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then |
758c442c GD |
420 | return True; |
421 | end if; | |
758c442c GD |
422 | end loop; |
423 | end if; | |
424 | ||
4d744221 JM |
425 | -- Look for the tag in the ancestor tags table. This is required for: |
426 | -- Iface_CW in Typ'Class | |
427 | ||
d0dd5209 | 428 | for Id in 0 .. Obj_TSD.Idepth loop |
4d744221 JM |
429 | if Obj_TSD.Tags_Table (Id) = T then |
430 | return True; | |
431 | end if; | |
432 | end loop; | |
433 | ||
758c442c GD |
434 | return False; |
435 | end IW_Membership; | |
436 | ||
d23b8f57 RK |
437 | ------------------- |
438 | -- Expanded_Name -- | |
439 | ------------------- | |
440 | ||
441 | function Expanded_Name (T : Tag) return String is | |
d0dd5209 JM |
442 | Result : Cstring_Ptr; |
443 | TSD_Ptr : Addr_Ptr; | |
444 | TSD : Type_Specific_Data_Ptr; | |
758c442c | 445 | |
d23b8f57 | 446 | begin |
758c442c GD |
447 | if T = No_Tag then |
448 | raise Tag_Error; | |
449 | end if; | |
450 | ||
d0dd5209 JM |
451 | TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); |
452 | TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); | |
453 | Result := TSD.Expanded_Name; | |
d23b8f57 RK |
454 | return Result (1 .. Length (Result)); |
455 | end Expanded_Name; | |
456 | ||
457 | ------------------ | |
458 | -- External_Tag -- | |
459 | ------------------ | |
460 | ||
461 | function External_Tag (T : Tag) return String is | |
d0dd5209 JM |
462 | Result : Cstring_Ptr; |
463 | TSD_Ptr : Addr_Ptr; | |
464 | TSD : Type_Specific_Data_Ptr; | |
f4d379b8 | 465 | |
d23b8f57 | 466 | begin |
758c442c GD |
467 | if T = No_Tag then |
468 | raise Tag_Error; | |
469 | end if; | |
470 | ||
d0dd5209 JM |
471 | TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); |
472 | TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); | |
473 | Result := TSD.External_Tag; | |
d23b8f57 RK |
474 | return Result (1 .. Length (Result)); |
475 | end External_Tag; | |
476 | ||
10b93b2e HK |
477 | --------------------- |
478 | -- Get_Entry_Index -- | |
479 | --------------------- | |
480 | ||
f4d379b8 | 481 | function Get_Entry_Index (T : Tag; Position : Positive) return Positive is |
10b93b2e | 482 | begin |
a05e99a2 | 483 | return SSD (T).SSD_Table (Position).Index; |
10b93b2e HK |
484 | end Get_Entry_Index; |
485 | ||
10b93b2e HK |
486 | ---------------------- |
487 | -- Get_Prim_Op_Kind -- | |
488 | ---------------------- | |
489 | ||
490 | function Get_Prim_Op_Kind | |
491 | (T : Tag; | |
f4d379b8 HK |
492 | Position : Positive) return Prim_Op_Kind |
493 | is | |
10b93b2e | 494 | begin |
a05e99a2 | 495 | return SSD (T).SSD_Table (Position).Kind; |
10b93b2e HK |
496 | end Get_Prim_Op_Kind; |
497 | ||
f4d379b8 HK |
498 | ---------------------- |
499 | -- Get_Offset_Index -- | |
500 | ---------------------- | |
501 | ||
502 | function Get_Offset_Index | |
4d744221 | 503 | (T : Tag; |
f4d379b8 HK |
504 | Position : Positive) return Positive |
505 | is | |
f4d379b8 | 506 | begin |
3d6efb77 JM |
507 | if Is_Primary_DT (T) then |
508 | return Position; | |
509 | else | |
510 | return OSD (T).OSD_Table (Position); | |
511 | end if; | |
f4d379b8 HK |
512 | end Get_Offset_Index; |
513 | ||
d23b8f57 RK |
514 | ------------------- |
515 | -- Get_RC_Offset -- | |
516 | ------------------- | |
517 | ||
518 | function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is | |
d0dd5209 JM |
519 | TSD_Ptr : constant Addr_Ptr := |
520 | To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); | |
521 | TSD : constant Type_Specific_Data_Ptr := | |
522 | To_Type_Specific_Data_Ptr (TSD_Ptr.all); | |
d23b8f57 | 523 | begin |
d0dd5209 | 524 | return TSD.RC_Offset; |
d23b8f57 RK |
525 | end Get_RC_Offset; |
526 | ||
4d744221 JM |
527 | --------------------- |
528 | -- Get_Tagged_Kind -- | |
529 | --------------------- | |
530 | ||
531 | function Get_Tagged_Kind (T : Tag) return Tagged_Kind is | |
4d744221 | 532 | begin |
d0dd5209 | 533 | return DT (T).Tag_Kind; |
4d744221 JM |
534 | end Get_Tagged_Kind; |
535 | ||
bfef8d0d JM |
536 | ----------------------------- |
537 | -- Interface_Ancestor_Tags -- | |
538 | ----------------------------- | |
539 | ||
540 | function Interface_Ancestor_Tags (T : Tag) return Tag_Array is | |
d0dd5209 JM |
541 | TSD_Ptr : constant Addr_Ptr := |
542 | To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); | |
543 | TSD : constant Type_Specific_Data_Ptr := | |
544 | To_Type_Specific_Data_Ptr (TSD_Ptr.all); | |
545 | Iface_Table : constant Interface_Data_Ptr := TSD.Interfaces_Table; | |
bfef8d0d JM |
546 | |
547 | begin | |
bfef8d0d JM |
548 | if Iface_Table = null then |
549 | declare | |
550 | Table : Tag_Array (1 .. 0); | |
551 | begin | |
552 | return Table; | |
553 | end; | |
554 | else | |
555 | declare | |
556 | Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces); | |
557 | begin | |
558 | for J in 1 .. Iface_Table.Nb_Ifaces loop | |
3d6efb77 | 559 | Table (J) := Iface_Table.Ifaces_Table (J).Iface_Tag; |
bfef8d0d JM |
560 | end loop; |
561 | ||
562 | return Table; | |
563 | end; | |
564 | end if; | |
565 | end Interface_Ancestor_Tags; | |
566 | ||
d23b8f57 RK |
567 | ------------------ |
568 | -- Internal_Tag -- | |
569 | ------------------ | |
570 | ||
d0dd5209 JM |
571 | -- Internal tags have the following format: |
572 | -- "Internal tag at 16#ADDRESS#: <full-name-of-tagged-type>" | |
573 | ||
574 | Internal_Tag_Header : constant String := "Internal tag at "; | |
575 | Header_Separator : constant Character := '#'; | |
576 | ||
d23b8f57 RK |
577 | function Internal_Tag (External : String) return Tag is |
578 | Ext_Copy : aliased String (External'First .. External'Last + 1); | |
d0dd5209 | 579 | Res : Tag := null; |
d23b8f57 RK |
580 | |
581 | begin | |
d0dd5209 JM |
582 | -- Handle locally defined tagged types |
583 | ||
584 | if External'Length > Internal_Tag_Header'Length | |
585 | and then | |
586 | External (External'First .. | |
587 | External'First + Internal_Tag_Header'Length - 1) | |
588 | = Internal_Tag_Header | |
589 | then | |
590 | declare | |
591 | Addr_First : constant Natural := | |
592 | External'First + Internal_Tag_Header'Length; | |
593 | Addr_Last : Natural; | |
594 | Addr : Integer_Address; | |
595 | ||
596 | begin | |
597 | -- Search the second separator (#) to identify the address | |
598 | ||
599 | Addr_Last := Addr_First; | |
600 | ||
601 | for J in 1 .. 2 loop | |
602 | while Addr_Last <= External'Last | |
603 | and then External (Addr_Last) /= Header_Separator | |
604 | loop | |
605 | Addr_Last := Addr_Last + 1; | |
606 | end loop; | |
607 | ||
608 | -- Skip the first separator | |
609 | ||
610 | if J = 1 then | |
611 | Addr_Last := Addr_Last + 1; | |
612 | end if; | |
613 | end loop; | |
614 | ||
615 | if Addr_Last <= External'Last then | |
a687fbb9 JM |
616 | |
617 | -- Protect the run-time against wrong internal tags. We | |
618 | -- cannot use exception handlers here because it would | |
619 | -- disable the use of this run-time compiling with | |
620 | -- restriction No_Exception_Handler. | |
621 | ||
622 | declare | |
623 | C : Character; | |
624 | Wrong_Tag : Boolean := False; | |
625 | ||
626 | begin | |
627 | if External (Addr_First) /= '1' | |
628 | or else External (Addr_First + 1) /= '6' | |
629 | or else External (Addr_First + 2) /= '#' | |
630 | then | |
631 | Wrong_Tag := True; | |
632 | ||
633 | else | |
634 | for J in Addr_First + 3 .. Addr_Last - 1 loop | |
635 | C := External (J); | |
636 | ||
637 | if not (C in '0' .. '9') | |
638 | and then not (C in 'A' .. 'F') | |
639 | and then not (C in 'a' .. 'f') | |
640 | then | |
641 | Wrong_Tag := True; | |
642 | exit; | |
643 | end if; | |
644 | end loop; | |
645 | end if; | |
646 | ||
647 | -- Convert the numeric value into a tag | |
648 | ||
649 | if not Wrong_Tag then | |
650 | Addr := Integer_Address'Value | |
651 | (External (Addr_First .. Addr_Last)); | |
652 | ||
653 | -- Internal tags never have value 0 | |
654 | ||
655 | if Addr /= 0 then | |
656 | return To_Tag (Addr); | |
657 | end if; | |
658 | end if; | |
659 | end; | |
d0dd5209 JM |
660 | end if; |
661 | end; | |
662 | ||
663 | -- Handle library-level tagged types | |
664 | ||
665 | else | |
cd3cd5b1 | 666 | -- Make NUL-terminated copy of external tag string |
d23b8f57 | 667 | |
d0dd5209 | 668 | Ext_Copy (External'Range) := External; |
cd3cd5b1 | 669 | Ext_Copy (Ext_Copy'Last) := ASCII.NUL; |
d0dd5209 JM |
670 | Res := External_Tag_HTable.Get (Ext_Copy'Address); |
671 | end if; | |
d23b8f57 RK |
672 | |
673 | if Res = null then | |
674 | declare | |
675 | Msg1 : constant String := "unknown tagged type: "; | |
676 | Msg2 : String (1 .. Msg1'Length + External'Length); | |
f4d379b8 | 677 | |
d23b8f57 RK |
678 | begin |
679 | Msg2 (1 .. Msg1'Length) := Msg1; | |
680 | Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) := | |
681 | External; | |
682 | Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2); | |
683 | end; | |
684 | end if; | |
685 | ||
686 | return Res; | |
687 | end Internal_Tag; | |
688 | ||
758c442c GD |
689 | --------------------------------- |
690 | -- Is_Descendant_At_Same_Level -- | |
691 | --------------------------------- | |
692 | ||
693 | function Is_Descendant_At_Same_Level | |
694 | (Descendant : Tag; | |
695 | Ancestor : Tag) return Boolean | |
696 | is | |
d0dd5209 JM |
697 | D_TSD_Ptr : constant Addr_Ptr := |
698 | To_Addr_Ptr (To_Address (Descendant) | |
699 | - DT_Typeinfo_Ptr_Size); | |
700 | A_TSD_Ptr : constant Addr_Ptr := | |
701 | To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size); | |
702 | D_TSD : constant Type_Specific_Data_Ptr := | |
703 | To_Type_Specific_Data_Ptr (D_TSD_Ptr.all); | |
704 | A_TSD : constant Type_Specific_Data_Ptr := | |
705 | To_Type_Specific_Data_Ptr (A_TSD_Ptr.all); | |
706 | ||
758c442c GD |
707 | begin |
708 | return CW_Membership (Descendant, Ancestor) | |
d0dd5209 | 709 | and then D_TSD.Access_Level = A_TSD.Access_Level; |
758c442c GD |
710 | end Is_Descendant_At_Same_Level; |
711 | ||
d23b8f57 RK |
712 | ------------ |
713 | -- Length -- | |
714 | ------------ | |
715 | ||
716 | function Length (Str : Cstring_Ptr) return Natural is | |
d0dd5209 | 717 | Len : Integer; |
d23b8f57 RK |
718 | |
719 | begin | |
d0dd5209 | 720 | Len := 1; |
f2cbd970 | 721 | while Str (Len) /= ASCII.NUL loop |
d23b8f57 RK |
722 | Len := Len + 1; |
723 | end loop; | |
724 | ||
725 | return Len - 1; | |
726 | end Length; | |
727 | ||
758c442c GD |
728 | ------------------- |
729 | -- Offset_To_Top -- | |
730 | ------------------- | |
731 | ||
732 | function Offset_To_Top | |
d0dd5209 | 733 | (This : System.Address) return SSE.Storage_Offset |
758c442c | 734 | is |
d0dd5209 JM |
735 | Tag_Size : constant SSE.Storage_Count := |
736 | SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); | |
a05e99a2 | 737 | |
d0dd5209 JM |
738 | type Storage_Offset_Ptr is access SSE.Storage_Offset; |
739 | function To_Storage_Offset_Ptr is | |
740 | new Unchecked_Conversion (System.Address, Storage_Offset_Ptr); | |
758c442c | 741 | |
d0dd5209 | 742 | Curr_DT : Dispatch_Table_Ptr; |
f4d379b8 | 743 | |
f4d379b8 | 744 | begin |
d0dd5209 JM |
745 | Curr_DT := DT (To_Tag_Ptr (This).all); |
746 | ||
747 | if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then | |
748 | return To_Storage_Offset_Ptr (This + Tag_Size).all; | |
749 | else | |
750 | return Curr_DT.Offset_To_Top; | |
751 | end if; | |
752 | end Offset_To_Top; | |
f4d379b8 | 753 | |
d23b8f57 RK |
754 | ----------------- |
755 | -- Parent_Size -- | |
756 | ----------------- | |
757 | ||
fbf5a39b | 758 | function Parent_Size |
8a6a52dc AC |
759 | (Obj : System.Address; |
760 | T : Tag) return SSE.Storage_Count | |
761 | is | |
bfef8d0d JM |
762 | Parent_Slot : constant Positive := 1; |
763 | -- The tag of the parent is always in the first slot of the table of | |
764 | -- ancestor tags. | |
765 | ||
d0dd5209 JM |
766 | TSD_Ptr : constant Addr_Ptr := |
767 | To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); | |
768 | TSD : constant Type_Specific_Data_Ptr := | |
769 | To_Type_Specific_Data_Ptr (TSD_Ptr.all); | |
770 | -- Pointer to the TSD | |
771 | ||
f2cbd970 JM |
772 | Parent_Tag : constant Tag := TSD.Tags_Table (Parent_Slot); |
773 | Parent_TSD_Ptr : constant Addr_Ptr := | |
774 | To_Addr_Ptr (To_Address (Parent_Tag) | |
775 | - DT_Typeinfo_Ptr_Size); | |
776 | Parent_TSD : constant Type_Specific_Data_Ptr := | |
777 | To_Type_Specific_Data_Ptr (Parent_TSD_Ptr.all); | |
d23b8f57 RK |
778 | |
779 | begin | |
780 | -- Here we compute the size of the _parent field of the object | |
781 | ||
f2cbd970 | 782 | return SSE.Storage_Count (Parent_TSD.Size_Func.all (Obj)); |
d23b8f57 RK |
783 | end Parent_Size; |
784 | ||
fbf5a39b AC |
785 | ---------------- |
786 | -- Parent_Tag -- | |
787 | ---------------- | |
788 | ||
789 | function Parent_Tag (T : Tag) return Tag is | |
d0dd5209 JM |
790 | TSD_Ptr : Addr_Ptr; |
791 | TSD : Type_Specific_Data_Ptr; | |
792 | ||
fbf5a39b | 793 | begin |
758c442c GD |
794 | if T = No_Tag then |
795 | raise Tag_Error; | |
796 | end if; | |
797 | ||
d0dd5209 JM |
798 | TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); |
799 | TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); | |
800 | ||
758c442c GD |
801 | -- The Parent_Tag of a root-level tagged type is defined to be No_Tag. |
802 | -- The first entry in the Ancestors_Tags array will be null for such | |
803 | -- a type, but it's better to be explicit about returning No_Tag in | |
804 | -- this case. | |
805 | ||
d0dd5209 | 806 | if TSD.Idepth = 0 then |
758c442c GD |
807 | return No_Tag; |
808 | else | |
d0dd5209 | 809 | return TSD.Tags_Table (1); |
758c442c | 810 | end if; |
fbf5a39b AC |
811 | end Parent_Tag; |
812 | ||
f2cbd970 JM |
813 | ------------------------------- |
814 | -- Register_Interface_Offset -- | |
815 | ------------------------------- | |
816 | ||
817 | procedure Register_Interface_Offset | |
818 | (This : System.Address; | |
819 | Interface_T : Tag; | |
820 | Is_Static : Boolean; | |
821 | Offset_Value : SSE.Storage_Offset; | |
822 | Offset_Func : Offset_To_Top_Function_Ptr) | |
823 | is | |
824 | Prim_DT : Dispatch_Table_Ptr; | |
825 | Iface_Table : Interface_Data_Ptr; | |
826 | ||
827 | begin | |
828 | -- "This" points to the primary DT and we must save Offset_Value in | |
829 | -- the Offset_To_Top field of the corresponding dispatch table. | |
830 | ||
831 | Prim_DT := DT (To_Tag_Ptr (This).all); | |
832 | Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table; | |
833 | ||
834 | -- Save Offset_Value in the table of interfaces of the primary DT. | |
835 | -- This data will be used by the subprogram "Displace" to give support | |
836 | -- to backward abstract interface type conversions. | |
837 | ||
838 | -- Register the offset in the table of interfaces | |
839 | ||
840 | if Iface_Table /= null then | |
841 | for Id in 1 .. Iface_Table.Nb_Ifaces loop | |
842 | if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then | |
843 | if Is_Static or else Offset_Value = 0 then | |
844 | Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := True; | |
845 | Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value := | |
846 | Offset_Value; | |
847 | else | |
848 | Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False; | |
849 | Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func := | |
850 | Offset_Func; | |
851 | end if; | |
852 | ||
853 | return; | |
854 | end if; | |
855 | end loop; | |
856 | end if; | |
857 | ||
858 | -- If we arrive here there is some error in the run-time data structure | |
859 | ||
860 | raise Program_Error; | |
861 | end Register_Interface_Offset; | |
862 | ||
d23b8f57 RK |
863 | ------------------ |
864 | -- Register_Tag -- | |
865 | ------------------ | |
866 | ||
867 | procedure Register_Tag (T : Tag) is | |
868 | begin | |
869 | External_Tag_HTable.Set (T); | |
870 | end Register_Tag; | |
871 | ||
470cd9e9 RD |
872 | ------------------- |
873 | -- Secondary_Tag -- | |
874 | ------------------- | |
875 | ||
876 | function Secondary_Tag (T, Iface : Tag) return Tag is | |
877 | Iface_Table : Interface_Data_Ptr; | |
878 | Obj_DT : Dispatch_Table_Ptr; | |
879 | ||
880 | begin | |
881 | if not Is_Primary_DT (T) then | |
882 | raise Program_Error; | |
883 | end if; | |
884 | ||
885 | Obj_DT := DT (T); | |
886 | Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table; | |
887 | ||
888 | if Iface_Table /= null then | |
889 | for Id in 1 .. Iface_Table.Nb_Ifaces loop | |
890 | if Iface_Table.Ifaces_Table (Id).Iface_Tag = Iface then | |
891 | return Iface_Table.Ifaces_Table (Id).Secondary_DT; | |
892 | end if; | |
893 | end loop; | |
894 | end if; | |
895 | ||
896 | -- If the object does not implement the interface we must raise CE | |
897 | ||
898 | raise Constraint_Error with "invalid interface conversion"; | |
899 | end Secondary_Tag; | |
900 | ||
10b93b2e HK |
901 | --------------------- |
902 | -- Set_Entry_Index -- | |
903 | --------------------- | |
904 | ||
905 | procedure Set_Entry_Index | |
906 | (T : Tag; | |
907 | Position : Positive; | |
f4d379b8 HK |
908 | Value : Positive) |
909 | is | |
10b93b2e | 910 | begin |
a05e99a2 | 911 | SSD (T).SSD_Table (Position).Index := Value; |
10b93b2e HK |
912 | end Set_Entry_Index; |
913 | ||
758c442c GD |
914 | ----------------------- |
915 | -- Set_Offset_To_Top -- | |
916 | ----------------------- | |
917 | ||
f2cbd970 | 918 | procedure Set_Dynamic_Offset_To_Top |
d0dd5209 JM |
919 | (This : System.Address; |
920 | Interface_T : Tag; | |
d0dd5209 JM |
921 | Offset_Value : SSE.Storage_Offset; |
922 | Offset_Func : Offset_To_Top_Function_Ptr) | |
758c442c | 923 | is |
f2cbd970 JM |
924 | Sec_Base : System.Address; |
925 | Sec_DT : Dispatch_Table_Ptr; | |
d0dd5209 JM |
926 | begin |
927 | -- Save the offset to top field in the secondary dispatch table | |
4d744221 | 928 | |
bfef8d0d JM |
929 | if Offset_Value /= 0 then |
930 | Sec_Base := This + Offset_Value; | |
f2cbd970 JM |
931 | Sec_DT := DT (To_Tag_Ptr (Sec_Base).all); |
932 | Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last; | |
a05e99a2 | 933 | end if; |
4d744221 | 934 | |
f2cbd970 JM |
935 | Register_Interface_Offset |
936 | (This, Interface_T, False, Offset_Value, Offset_Func); | |
937 | end Set_Dynamic_Offset_To_Top; | |
758c442c | 938 | |
10b93b2e HK |
939 | ---------------------- |
940 | -- Set_Prim_Op_Kind -- | |
941 | ---------------------- | |
942 | ||
943 | procedure Set_Prim_Op_Kind | |
944 | (T : Tag; | |
945 | Position : Positive; | |
f4d379b8 HK |
946 | Value : Prim_Op_Kind) |
947 | is | |
10b93b2e | 948 | begin |
a05e99a2 | 949 | SSD (T).SSD_Table (Position).Kind := Value; |
10b93b2e HK |
950 | end Set_Prim_Op_Kind; |
951 | ||
a05e99a2 JM |
952 | ------------------------ |
953 | -- Wide_Expanded_Name -- | |
954 | ------------------------ | |
955 | ||
956 | WC_Encoding : Character; | |
957 | pragma Import (C, WC_Encoding, "__gl_wc_encoding"); | |
958 | -- Encoding method for source, as exported by binder | |
959 | ||
960 | function Wide_Expanded_Name (T : Tag) return Wide_String is | |
470cd9e9 RD |
961 | S : constant String := Expanded_Name (T); |
962 | W : Wide_String (1 .. S'Length); | |
963 | L : Natural; | |
a05e99a2 | 964 | begin |
470cd9e9 RD |
965 | String_To_Wide_String |
966 | (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); | |
967 | return W (1 .. L); | |
a05e99a2 JM |
968 | end Wide_Expanded_Name; |
969 | ||
970 | ----------------------------- | |
971 | -- Wide_Wide_Expanded_Name -- | |
972 | ----------------------------- | |
973 | ||
974 | function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is | |
470cd9e9 RD |
975 | S : constant String := Expanded_Name (T); |
976 | W : Wide_Wide_String (1 .. S'Length); | |
977 | L : Natural; | |
a05e99a2 | 978 | begin |
470cd9e9 RD |
979 | String_To_Wide_Wide_String |
980 | (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); | |
981 | return W (1 .. L); | |
a05e99a2 JM |
982 | end Wide_Wide_Expanded_Name; |
983 | ||
d23b8f57 | 984 | end Ada.Tags; |