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