1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
9 -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
33 with Ada.Unchecked_Conversion;
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
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
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.
126 -- Canonical implementation of Classwide Membership corresponding to:
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)
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;
153 return Pos >= 0 and then Obj_TSD.Tags_Table (Pos) = Typ_Tag;
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);
166 return To_Address (TSD.External_Tag);
167 end Get_External_Tag;
173 function Is_Primary_DT (T : Tag) return Boolean is
175 return DT (T).Signature = Primary_DT;
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);
186 return To_Object_Specific_Data_Ptr (OSD_Ptr.all);
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);
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,
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
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);
250 if Str1 (J) /= Str2 (J) then
252 elsif Str1 (J) = ASCII.NUL then
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);
270 return TSD.HT_Link.all;
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)));
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);
295 TSD.HT_Link.all := Next;
298 end HTable_Subprograms;
304 function Base_Address (This : System.Address) return System.Address is
306 return This - Offset_To_Top (This);
313 procedure Check_TSD (TSD : Type_Specific_Data_Ptr) is
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 """;
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));
331 -- Avoid concatenation, as it is not allowed in no run time mode
334 Msg : String (1 .. Dup_Ext_Tag'Length + E_Tag_Len + 1);
336 Msg (1 .. Dup_Ext_Tag'Length) := Dup_Ext_Tag;
337 Msg (Dup_Ext_Tag'Length + 1 .. Dup_Ext_Tag'Length + E_Tag_Len) :=
339 Msg (Msg'Last) := '"';
340 raise Program_Error with Msg;
349 function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
350 Int_Tag : constant Tag := Internal_Tag (External);
352 if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
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;
370 if System."=" (This, System.Null_Address) then
371 return System.Null_Address;
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.
393 Obj_Base := Obj_Base +
394 Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func.all
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
410 -- If the object does not implement the interface we must raise CE
412 raise Constraint_Error with "invalid interface conversion";
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;
423 return To_Dispatch_Table_Ptr (To_Address (T) - Offset);
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;
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
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
476 function Expanded_Name (T : Tag) return String is
477 Result : Cstring_Ptr;
479 TSD : Type_Specific_Data_Ptr;
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));
496 function External_Tag (T : Tag) return String is
497 Result : Cstring_Ptr;
499 TSD : Type_Specific_Data_Ptr;
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));
512 ---------------------
513 -- Get_Entry_Index --
514 ---------------------
516 function Get_Entry_Index (T : Tag; Position : Positive) return Positive is
518 return SSD (T).SSD_Table (Position).Index;
521 ----------------------
522 -- Get_Prim_Op_Kind --
523 ----------------------
525 function Get_Prim_Op_Kind
527 Position : Positive) return Prim_Op_Kind
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
539 Position : Positive) return Positive
542 if Is_Primary_DT (T) then
545 return OSD (T).OSD_Table (Position);
547 end Get_Offset_Index;
549 ---------------------
550 -- Get_Tagged_Kind --
551 ---------------------
553 function Get_Tagged_Kind (T : Tag) return Tagged_Kind is
555 return DT (T).Tag_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;
570 if Iface_Table = null then
572 Table : Tag_Array (1 .. 0);
579 Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces);
581 for J in 1 .. Iface_Table.Nb_Ifaces loop
582 Table (J) := Iface_Table.Ifaces_Table (J).Iface_Tag;
588 end Interface_Ancestor_Tags;
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);
605 -- Handle locally defined tagged types
607 if External'Length > Internal_Tag_Header'Length
609 External (External'First ..
610 External'First + Internal_Tag_Header'Length - 1) =
614 Addr_First : constant Natural :=
615 External'First + Internal_Tag_Header'Length;
617 Addr : Integer_Address;
620 -- Search the second separator (#) to identify the address
622 Addr_Last := Addr_First;
625 while Addr_Last <= External'Last
626 and then External (Addr_Last) /= Header_Separator
628 Addr_Last := Addr_Last + 1;
631 -- Skip the first separator
634 Addr_Last := Addr_Last + 1;
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.
647 Wrong_Tag : Boolean := False;
650 if External (Addr_First) /= '1'
651 or else External (Addr_First + 1) /= '6'
652 or else External (Addr_First + 2) /= '#'
657 for J in Addr_First + 3 .. Addr_Last - 1 loop
660 if not (C in '0' .. '9')
661 and then not (C in 'A' .. 'F')
662 and then not (C in 'a' .. 'f')
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
679 return To_Tag (Addr);
686 -- Handle library-level tagged types
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);
698 Msg1 : constant String := "unknown tagged type: ";
699 Msg2 : String (1 .. Msg1'Length + External'Length);
702 Msg2 (1 .. Msg1'Length) := Msg1;
703 Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
705 Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2);
712 ---------------------------------
713 -- Is_Descendant_At_Same_Level --
714 ---------------------------------
716 function Is_Descendant_At_Same_Level
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);
730 return CW_Membership (Descendant, Ancestor)
731 and then D_TSD.Access_Level = A_TSD.Access_Level;
732 end Is_Descendant_At_Same_Level;
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
743 function Length (Str : Cstring_Ptr) return Natural is
748 while Str (Len) /= ASCII.NUL loop
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;
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;
777 return Curr_DT.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);
791 return TSD.Needs_Finalization;
792 end Needs_Finalization;
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
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);
819 -- Here we compute the size of the _parent field of the object
821 return SSE.Storage_Count (Parent_TSD.Size_Func.all (Obj));
828 function Parent_Tag (T : Tag) return Tag is
830 TSD : Type_Specific_Data_Ptr;
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
845 if TSD.Idepth = 0 then
848 return TSD.Tags_Table (1);
852 -------------------------------
853 -- Register_Interface_Offset --
854 -------------------------------
856 procedure Register_Interface_Offset
857 (This : System.Address;
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;
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 :=
887 Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False;
888 Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func :=
897 -- If we arrive here there is some error in the run-time data structure
900 end Register_Interface_Offset;
906 procedure Register_Tag (T : Tag) is
908 External_Tag_HTable.Set (T);
915 function Secondary_Tag (T, Iface : Tag) return Tag is
916 Iface_Table : Interface_Data_Ptr;
917 Obj_DT : Dispatch_Table_Ptr;
920 if not Is_Primary_DT (T) then
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;
935 -- If the object does not implement the interface we must raise CE
937 raise Constraint_Error with "invalid interface conversion";
940 ---------------------
941 -- Set_Entry_Index --
942 ---------------------
944 procedure Set_Entry_Index
950 SSD (T).SSD_Table (Position).Index := Value;
953 -----------------------
954 -- Set_Offset_To_Top --
955 -----------------------
957 procedure Set_Dynamic_Offset_To_Top
958 (This : System.Address;
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;
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;
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
986 Value : Prim_Op_Kind)
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
998 TSD : Type_Specific_Data_Ptr;
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
1016 External_Tag_HTable.Remove (Get_External_Tag (T));
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);
1032 String_To_Wide_String
1033 (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
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);
1046 String_To_Wide_Wide_String
1047 (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
1049 end Wide_Wide_Expanded_Name;