1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
9 -- Copyright (C) 1992-2009, 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;
35 with System.Storage_Elements; use System.Storage_Elements;
36 with System.WCh_Con; use System.WCh_Con;
37 with System.WCh_StW; use System.WCh_StW;
39 pragma Elaborate_All (System.HTable);
41 package body Ada.Tags is
43 -----------------------
44 -- Local Subprograms --
45 -----------------------
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.
51 function Get_External_Tag (T : Tag) return System.Address;
52 -- Returns address of a null terminated string containing the external name
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.
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).
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
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.
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);
78 -- Unchecked conversions
80 function To_Address is
81 new Unchecked_Conversion (Cstring_Ptr, System.Address);
83 function To_Cstring_Ptr is
84 new Unchecked_Conversion (System.Address, Cstring_Ptr);
86 -- Disable warnings on possible aliasing problem
89 new Unchecked_Conversion (Integer_Address, Tag);
91 function To_Addr_Ptr is
92 new Ada.Unchecked_Conversion (System.Address, Addr_Ptr);
94 function To_Address is
95 new Ada.Unchecked_Conversion (Tag, System.Address);
97 function To_Dispatch_Table_Ptr is
98 new Ada.Unchecked_Conversion (Tag, Dispatch_Table_Ptr);
100 function To_Dispatch_Table_Ptr is
101 new Ada.Unchecked_Conversion (System.Address, Dispatch_Table_Ptr);
103 function To_Object_Specific_Data_Ptr is
104 new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr);
106 function To_Tag_Ptr is
107 new Ada.Unchecked_Conversion (System.Address, Tag_Ptr);
109 function To_Type_Specific_Data_Ptr is
110 new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
112 -------------------------------
113 -- Inline_Always Subprograms --
114 -------------------------------
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.
124 -- Canonical implementation of Classwide Membership corresponding to:
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".
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:
137 -- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
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;
151 return Pos >= 0 and then Obj_TSD.Tags_Table (Pos) = Typ_Tag;
154 ----------------------
155 -- Get_External_Tag --
156 ----------------------
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);
164 return To_Address (TSD.External_Tag);
165 end Get_External_Tag;
171 function Is_Primary_DT (T : Tag) return Boolean is
173 return DT (T).Signature = Primary_DT;
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);
184 return To_Object_Specific_Data_Ptr (OSD_Ptr.all);
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);
200 -------------------------
201 -- External_Tag_HTable --
202 -------------------------
204 type HTable_Headers is range 1 .. 64;
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.
210 package HTable_Subprograms is
211 procedure Set_HT_Link (T : Tag; Next : Tag);
212 function Get_HT_Link (T : Tag) return Tag;
213 function Hash (F : System.Address) return HTable_Headers;
214 function Equal (A, B : System.Address) return Boolean;
215 end HTable_Subprograms;
217 package External_Tag_HTable is new System.HTable.Static_HTable (
218 Header_Num => HTable_Headers,
219 Element => Dispatch_Table,
222 Set_Next => HTable_Subprograms.Set_HT_Link,
223 Next => HTable_Subprograms.Get_HT_Link,
224 Key => System.Address,
225 Get_Key => Get_External_Tag,
226 Hash => HTable_Subprograms.Hash,
227 Equal => HTable_Subprograms.Equal);
229 ------------------------
230 -- HTable_Subprograms --
231 ------------------------
233 -- Bodies of routines for hash table instantiation
235 package body HTable_Subprograms is
241 function Equal (A, B : System.Address) return Boolean is
242 Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
243 Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
247 if Str1 (J) /= Str2 (J) then
249 elsif Str1 (J) = ASCII.NUL then
261 function Get_HT_Link (T : Tag) return Tag is
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);
267 return TSD.HT_Link.all;
274 function Hash (F : System.Address) return HTable_Headers is
275 function H is new System.HTable.Hash (HTable_Headers);
276 Str : constant Cstring_Ptr := To_Cstring_Ptr (F);
277 Res : constant HTable_Headers := H (Str (1 .. Length (Str)));
286 procedure Set_HT_Link (T : Tag; Next : Tag) is
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);
292 TSD.HT_Link.all := Next;
295 end HTable_Subprograms;
301 function Base_Address (This : System.Address) return System.Address is
303 return This - Offset_To_Top (This);
310 function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
311 Int_Tag : constant Tag := Internal_Tag (External);
314 if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
326 (This : System.Address;
327 T : Tag) return System.Address
329 Iface_Table : Interface_Data_Ptr;
330 Obj_Base : System.Address;
331 Obj_DT : Dispatch_Table_Ptr;
335 if System."=" (This, System.Null_Address) then
336 return System.Null_Address;
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;
344 if Iface_Table /= null then
345 for Id in 1 .. Iface_Table.Nb_Ifaces loop
346 if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then
348 -- Case of Static value of Offset_To_Top
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;
354 -- Otherwise call the function generated by the expander to
355 -- provide the value.
358 Obj_Base := Obj_Base +
359 Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func.all
368 -- Check if T is an immediate ancestor. This is required to handle
369 -- conversion of class-wide interfaces to tagged types.
371 if CW_Membership (Obj_DT_Tag, T) then
375 -- If the object does not implement the interface we must raise CE
377 raise Constraint_Error with "invalid interface conversion";
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;
388 return To_Dispatch_Table_Ptr (To_Address (T) - Offset);
395 -- Canonical implementation of Classwide Membership corresponding to:
397 -- Obj in Iface'Class
399 -- Each dispatch table contains a table with the tags of all the
400 -- implemented interfaces.
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.
405 function IW_Membership (This : System.Address; T : Tag) return Boolean is
406 Iface_Table : Interface_Data_Ptr;
407 Obj_Base : System.Address;
408 Obj_DT : Dispatch_Table_Ptr;
409 Obj_TSD : Type_Specific_Data_Ptr;
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;
417 if Iface_Table /= null then
418 for Id in 1 .. Iface_Table.Nb_Ifaces loop
419 if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then
425 -- Look for the tag in the ancestor tags table. This is required for:
426 -- Iface_CW in Typ'Class
428 for Id in 0 .. Obj_TSD.Idepth loop
429 if Obj_TSD.Tags_Table (Id) = T then
441 function Expanded_Name (T : Tag) return String is
442 Result : Cstring_Ptr;
444 TSD : Type_Specific_Data_Ptr;
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;
454 return Result (1 .. Length (Result));
461 function External_Tag (T : Tag) return String is
462 Result : Cstring_Ptr;
464 TSD : Type_Specific_Data_Ptr;
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;
474 return Result (1 .. Length (Result));
477 ---------------------
478 -- Get_Entry_Index --
479 ---------------------
481 function Get_Entry_Index (T : Tag; Position : Positive) return Positive is
483 return SSD (T).SSD_Table (Position).Index;
486 ----------------------
487 -- Get_Prim_Op_Kind --
488 ----------------------
490 function Get_Prim_Op_Kind
492 Position : Positive) return Prim_Op_Kind
495 return SSD (T).SSD_Table (Position).Kind;
496 end Get_Prim_Op_Kind;
498 ----------------------
499 -- Get_Offset_Index --
500 ----------------------
502 function Get_Offset_Index
504 Position : Positive) return Positive
507 if Is_Primary_DT (T) then
510 return OSD (T).OSD_Table (Position);
512 end Get_Offset_Index;
518 function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is
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);
524 return TSD.RC_Offset;
527 ---------------------
528 -- Get_Tagged_Kind --
529 ---------------------
531 function Get_Tagged_Kind (T : Tag) return Tagged_Kind is
533 return DT (T).Tag_Kind;
536 -----------------------------
537 -- Interface_Ancestor_Tags --
538 -----------------------------
540 function Interface_Ancestor_Tags (T : Tag) return Tag_Array is
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;
548 if Iface_Table = null then
550 Table : Tag_Array (1 .. 0);
556 Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces);
558 for J in 1 .. Iface_Table.Nb_Ifaces loop
559 Table (J) := Iface_Table.Ifaces_Table (J).Iface_Tag;
565 end Interface_Ancestor_Tags;
571 -- Internal tags have the following format:
572 -- "Internal tag at 16#ADDRESS#: <full-name-of-tagged-type>"
574 Internal_Tag_Header : constant String := "Internal tag at ";
575 Header_Separator : constant Character := '#';
577 function Internal_Tag (External : String) return Tag is
578 Ext_Copy : aliased String (External'First .. External'Last + 1);
582 -- Handle locally defined tagged types
584 if External'Length > Internal_Tag_Header'Length
586 External (External'First ..
587 External'First + Internal_Tag_Header'Length - 1)
588 = Internal_Tag_Header
591 Addr_First : constant Natural :=
592 External'First + Internal_Tag_Header'Length;
594 Addr : Integer_Address;
597 -- Search the second separator (#) to identify the address
599 Addr_Last := Addr_First;
602 while Addr_Last <= External'Last
603 and then External (Addr_Last) /= Header_Separator
605 Addr_Last := Addr_Last + 1;
608 -- Skip the first separator
611 Addr_Last := Addr_Last + 1;
615 if Addr_Last <= External'Last then
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.
624 Wrong_Tag : Boolean := False;
627 if External (Addr_First) /= '1'
628 or else External (Addr_First + 1) /= '6'
629 or else External (Addr_First + 2) /= '#'
634 for J in Addr_First + 3 .. Addr_Last - 1 loop
637 if not (C in '0' .. '9')
638 and then not (C in 'A' .. 'F')
639 and then not (C in 'a' .. 'f')
647 -- Convert the numeric value into a tag
649 if not Wrong_Tag then
650 Addr := Integer_Address'Value
651 (External (Addr_First .. Addr_Last));
653 -- Internal tags never have value 0
656 return To_Tag (Addr);
663 -- Handle library-level tagged types
666 -- Make NUL-terminated copy of external tag string
668 Ext_Copy (External'Range) := External;
669 Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
670 Res := External_Tag_HTable.Get (Ext_Copy'Address);
675 Msg1 : constant String := "unknown tagged type: ";
676 Msg2 : String (1 .. Msg1'Length + External'Length);
679 Msg2 (1 .. Msg1'Length) := Msg1;
680 Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
682 Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2);
689 ---------------------------------
690 -- Is_Descendant_At_Same_Level --
691 ---------------------------------
693 function Is_Descendant_At_Same_Level
695 Ancestor : Tag) return Boolean
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);
708 return CW_Membership (Descendant, Ancestor)
709 and then D_TSD.Access_Level = A_TSD.Access_Level;
710 end Is_Descendant_At_Same_Level;
716 function Length (Str : Cstring_Ptr) return Natural is
721 while Str (Len) /= ASCII.NUL loop
732 function Offset_To_Top
733 (This : System.Address) return SSE.Storage_Offset
735 Tag_Size : constant SSE.Storage_Count :=
736 SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
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);
742 Curr_DT : Dispatch_Table_Ptr;
745 Curr_DT := DT (To_Tag_Ptr (This).all);
747 if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then
748 return To_Storage_Offset_Ptr (This + Tag_Size).all;
750 return Curr_DT.Offset_To_Top;
759 (Obj : System.Address;
760 T : Tag) return SSE.Storage_Count
762 Parent_Slot : constant Positive := 1;
763 -- The tag of the parent is always in the first slot of the table of
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
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);
780 -- Here we compute the size of the _parent field of the object
782 return SSE.Storage_Count (Parent_TSD.Size_Func.all (Obj));
789 function Parent_Tag (T : Tag) return Tag is
791 TSD : Type_Specific_Data_Ptr;
798 TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
799 TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
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
806 if TSD.Idepth = 0 then
809 return TSD.Tags_Table (1);
813 -------------------------------
814 -- Register_Interface_Offset --
815 -------------------------------
817 procedure Register_Interface_Offset
818 (This : System.Address;
821 Offset_Value : SSE.Storage_Offset;
822 Offset_Func : Offset_To_Top_Function_Ptr)
824 Prim_DT : Dispatch_Table_Ptr;
825 Iface_Table : Interface_Data_Ptr;
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.
831 Prim_DT := DT (To_Tag_Ptr (This).all);
832 Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
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.
838 -- Register the offset in the table of interfaces
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 :=
848 Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False;
849 Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func :=
858 -- If we arrive here there is some error in the run-time data structure
861 end Register_Interface_Offset;
867 procedure Register_Tag (T : Tag) is
869 External_Tag_HTable.Set (T);
876 function Secondary_Tag (T, Iface : Tag) return Tag is
877 Iface_Table : Interface_Data_Ptr;
878 Obj_DT : Dispatch_Table_Ptr;
881 if not Is_Primary_DT (T) then
886 Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table;
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;
896 -- If the object does not implement the interface we must raise CE
898 raise Constraint_Error with "invalid interface conversion";
901 ---------------------
902 -- Set_Entry_Index --
903 ---------------------
905 procedure Set_Entry_Index
911 SSD (T).SSD_Table (Position).Index := Value;
914 -----------------------
915 -- Set_Offset_To_Top --
916 -----------------------
918 procedure Set_Dynamic_Offset_To_Top
919 (This : System.Address;
921 Offset_Value : SSE.Storage_Offset;
922 Offset_Func : Offset_To_Top_Function_Ptr)
924 Sec_Base : System.Address;
925 Sec_DT : Dispatch_Table_Ptr;
927 -- Save the offset to top field in the secondary dispatch table
929 if Offset_Value /= 0 then
930 Sec_Base := This + Offset_Value;
931 Sec_DT := DT (To_Tag_Ptr (Sec_Base).all);
932 Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last;
935 Register_Interface_Offset
936 (This, Interface_T, False, Offset_Value, Offset_Func);
937 end Set_Dynamic_Offset_To_Top;
939 ----------------------
940 -- Set_Prim_Op_Kind --
941 ----------------------
943 procedure Set_Prim_Op_Kind
946 Value : Prim_Op_Kind)
949 SSD (T).SSD_Table (Position).Kind := Value;
950 end Set_Prim_Op_Kind;
952 ------------------------
953 -- Wide_Expanded_Name --
954 ------------------------
956 WC_Encoding : Character;
957 pragma Import (C, WC_Encoding, "__gl_wc_encoding");
958 -- Encoding method for source, as exported by binder
960 function Wide_Expanded_Name (T : Tag) return Wide_String is
961 S : constant String := Expanded_Name (T);
962 W : Wide_String (1 .. S'Length);
965 String_To_Wide_String
966 (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
968 end Wide_Expanded_Name;
970 -----------------------------
971 -- Wide_Wide_Expanded_Name --
972 -----------------------------
974 function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is
975 S : constant String := Expanded_Name (T);
976 W : Wide_Wide_String (1 .. S'Length);
979 String_To_Wide_Wide_String
980 (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
982 end Wide_Wide_Expanded_Name;