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