1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
9 -- Copyright (C) 1992-2012, 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 procedure Check_TSD
(TSD
: Type_Specific_Data_Ptr
) is
313 E_Tag_Len
: constant Integer := Length
(TSD
.External_Tag
);
314 E_Tag
: String (1 .. E_Tag_Len
);
315 for E_Tag
'Address use TSD
.External_Tag
.all'Address;
316 pragma Import
(Ada
, E_Tag
);
318 Dup_Ext_Tag
: constant String := "duplicated external tag """;
321 -- Verify that the external tag of this TSD is not registered in the
322 -- runtime hash table.
324 T
:= External_Tag_HTable
.Get
(To_Address
(TSD
.External_Tag
));
328 -- Avoid concatenation, as it is not allowed in no run time mode
331 Msg
: String (1 .. Dup_Ext_Tag
'Length + E_Tag_Len
+ 1);
333 Msg
(1 .. Dup_Ext_Tag
'Length) := Dup_Ext_Tag
;
334 Msg
(Dup_Ext_Tag
'Length + 1 .. Dup_Ext_Tag
'Length + E_Tag_Len
) :=
336 Msg
(Msg
'Last) := '"';
337 raise Program_Error
with Msg
;
346 function Descendant_Tag
(External
: String; Ancestor
: Tag
) return Tag
is
347 Int_Tag
: constant Tag
:= Internal_Tag
(External
);
350 if not Is_Descendant_At_Same_Level
(Int_Tag
, Ancestor
) then
362 (This
: System
.Address
;
363 T
: Tag
) return System
.Address
365 Iface_Table
: Interface_Data_Ptr
;
366 Obj_Base
: System
.Address
;
367 Obj_DT
: Dispatch_Table_Ptr
;
371 if System
."=" (This
, System
.Null_Address
) then
372 return System
.Null_Address
;
375 Obj_Base
:= Base_Address
(This
);
376 Obj_DT_Tag
:= To_Tag_Ptr
(Obj_Base
).all;
377 Obj_DT
:= DT
(To_Tag_Ptr
(Obj_Base
).all);
378 Iface_Table
:= To_Type_Specific_Data_Ptr
(Obj_DT
.TSD
).Interfaces_Table
;
380 if Iface_Table
/= null then
381 for Id
in 1 .. Iface_Table
.Nb_Ifaces
loop
382 if Iface_Table
.Ifaces_Table
(Id
).Iface_Tag
= T
then
384 -- Case of Static value of Offset_To_Top
386 if Iface_Table
.Ifaces_Table
(Id
).Static_Offset_To_Top
then
387 Obj_Base
:= Obj_Base
+
388 Iface_Table
.Ifaces_Table
(Id
).Offset_To_Top_Value
;
390 -- Otherwise call the function generated by the expander to
391 -- provide the value.
394 Obj_Base
:= Obj_Base
+
395 Iface_Table
.Ifaces_Table
(Id
).Offset_To_Top_Func
.all
404 -- Check if T is an immediate ancestor. This is required to handle
405 -- conversion of class-wide interfaces to tagged types.
407 if CW_Membership
(Obj_DT_Tag
, T
) then
411 -- If the object does not implement the interface we must raise CE
413 raise Constraint_Error
with "invalid interface conversion";
420 function DT
(T
: Tag
) return Dispatch_Table_Ptr
is
421 Offset
: constant SSE
.Storage_Offset
:=
422 To_Dispatch_Table_Ptr
(T
).Prims_Ptr
'Position;
424 return To_Dispatch_Table_Ptr
(To_Address
(T
) - Offset
);
431 -- Canonical implementation of Classwide Membership corresponding to:
433 -- Obj in Iface'Class
435 -- Each dispatch table contains a table with the tags of all the
436 -- implemented interfaces.
438 -- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
439 -- that are contained in the dispatch table referenced by Obj'Tag.
441 function IW_Membership
(This
: System
.Address
; T
: Tag
) return Boolean is
442 Iface_Table
: Interface_Data_Ptr
;
443 Obj_Base
: System
.Address
;
444 Obj_DT
: Dispatch_Table_Ptr
;
445 Obj_TSD
: Type_Specific_Data_Ptr
;
448 Obj_Base
:= Base_Address
(This
);
449 Obj_DT
:= DT
(To_Tag_Ptr
(Obj_Base
).all);
450 Obj_TSD
:= To_Type_Specific_Data_Ptr
(Obj_DT
.TSD
);
451 Iface_Table
:= Obj_TSD
.Interfaces_Table
;
453 if Iface_Table
/= null then
454 for Id
in 1 .. Iface_Table
.Nb_Ifaces
loop
455 if Iface_Table
.Ifaces_Table
(Id
).Iface_Tag
= T
then
461 -- Look for the tag in the ancestor tags table. This is required for:
462 -- Iface_CW in Typ'Class
464 for Id
in 0 .. Obj_TSD
.Idepth
loop
465 if Obj_TSD
.Tags_Table
(Id
) = T
then
477 function Expanded_Name
(T
: Tag
) return String is
478 Result
: Cstring_Ptr
;
480 TSD
: Type_Specific_Data_Ptr
;
487 TSD_Ptr
:= To_Addr_Ptr
(To_Address
(T
) - DT_Typeinfo_Ptr_Size
);
488 TSD
:= To_Type_Specific_Data_Ptr
(TSD_Ptr
.all);
489 Result
:= TSD
.Expanded_Name
;
490 return Result
(1 .. Length
(Result
));
497 function External_Tag
(T
: Tag
) return String is
498 Result
: Cstring_Ptr
;
500 TSD
: Type_Specific_Data_Ptr
;
507 TSD_Ptr
:= To_Addr_Ptr
(To_Address
(T
) - DT_Typeinfo_Ptr_Size
);
508 TSD
:= To_Type_Specific_Data_Ptr
(TSD_Ptr
.all);
509 Result
:= TSD
.External_Tag
;
510 return Result
(1 .. Length
(Result
));
513 ---------------------
514 -- Get_Entry_Index --
515 ---------------------
517 function Get_Entry_Index
(T
: Tag
; Position
: Positive) return Positive is
519 return SSD
(T
).SSD_Table
(Position
).Index
;
522 ----------------------
523 -- Get_Prim_Op_Kind --
524 ----------------------
526 function Get_Prim_Op_Kind
528 Position
: Positive) return Prim_Op_Kind
531 return SSD
(T
).SSD_Table
(Position
).Kind
;
532 end Get_Prim_Op_Kind
;
534 ----------------------
535 -- Get_Offset_Index --
536 ----------------------
538 function Get_Offset_Index
540 Position
: Positive) return Positive
543 if Is_Primary_DT
(T
) then
546 return OSD
(T
).OSD_Table
(Position
);
548 end Get_Offset_Index
;
550 ---------------------
551 -- Get_Tagged_Kind --
552 ---------------------
554 function Get_Tagged_Kind
(T
: Tag
) return Tagged_Kind
is
556 return DT
(T
).Tag_Kind
;
559 -----------------------------
560 -- Interface_Ancestor_Tags --
561 -----------------------------
563 function Interface_Ancestor_Tags
(T
: Tag
) return Tag_Array
is
564 TSD_Ptr
: constant Addr_Ptr
:=
565 To_Addr_Ptr
(To_Address
(T
) - DT_Typeinfo_Ptr_Size
);
566 TSD
: constant Type_Specific_Data_Ptr
:=
567 To_Type_Specific_Data_Ptr
(TSD_Ptr
.all);
568 Iface_Table
: constant Interface_Data_Ptr
:= TSD
.Interfaces_Table
;
571 if Iface_Table
= null then
573 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)
611 = Internal_Tag_Header
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 -- Should this be reimplemented using the strlen GCC builtin???
740 function Length
(Str
: Cstring_Ptr
) return Natural is
745 while Str
(Len
) /= ASCII
.NUL
loop
756 function Offset_To_Top
757 (This
: System
.Address
) return SSE
.Storage_Offset
759 Tag_Size
: constant SSE
.Storage_Count
:=
760 SSE
.Storage_Count
(1 * (Standard
'Address_Size / System
.Storage_Unit
));
762 type Storage_Offset_Ptr
is access SSE
.Storage_Offset
;
763 function To_Storage_Offset_Ptr
is
764 new Unchecked_Conversion
(System
.Address
, Storage_Offset_Ptr
);
766 Curr_DT
: Dispatch_Table_Ptr
;
769 Curr_DT
:= DT
(To_Tag_Ptr
(This
).all);
771 if Curr_DT
.Offset_To_Top
= SSE
.Storage_Offset
'Last then
772 return To_Storage_Offset_Ptr
(This
+ Tag_Size
).all;
774 return Curr_DT
.Offset_To_Top
;
778 ------------------------
779 -- Needs_Finalization --
780 ------------------------
782 function Needs_Finalization
(T
: Tag
) return Boolean is
783 TSD_Ptr
: constant Addr_Ptr
:=
784 To_Addr_Ptr
(To_Address
(T
) - DT_Typeinfo_Ptr_Size
);
785 TSD
: constant Type_Specific_Data_Ptr
:=
786 To_Type_Specific_Data_Ptr
(TSD_Ptr
.all);
788 return TSD
.Needs_Finalization
;
789 end Needs_Finalization
;
796 (Obj
: System
.Address
;
797 T
: Tag
) return SSE
.Storage_Count
799 Parent_Slot
: constant Positive := 1;
800 -- The tag of the parent is always in the first slot of the table of
803 TSD_Ptr
: constant Addr_Ptr
:=
804 To_Addr_Ptr
(To_Address
(T
) - DT_Typeinfo_Ptr_Size
);
805 TSD
: constant Type_Specific_Data_Ptr
:=
806 To_Type_Specific_Data_Ptr
(TSD_Ptr
.all);
807 -- Pointer to the TSD
809 Parent_Tag
: constant Tag
:= TSD
.Tags_Table
(Parent_Slot
);
810 Parent_TSD_Ptr
: constant Addr_Ptr
:=
811 To_Addr_Ptr
(To_Address
(Parent_Tag
) - DT_Typeinfo_Ptr_Size
);
812 Parent_TSD
: constant Type_Specific_Data_Ptr
:=
813 To_Type_Specific_Data_Ptr
(Parent_TSD_Ptr
.all);
816 -- Here we compute the size of the _parent field of the object
818 return SSE
.Storage_Count
(Parent_TSD
.Size_Func
.all (Obj
));
825 function Parent_Tag
(T
: Tag
) return Tag
is
827 TSD
: Type_Specific_Data_Ptr
;
834 TSD_Ptr
:= To_Addr_Ptr
(To_Address
(T
) - DT_Typeinfo_Ptr_Size
);
835 TSD
:= To_Type_Specific_Data_Ptr
(TSD_Ptr
.all);
837 -- The Parent_Tag of a root-level tagged type is defined to be No_Tag.
838 -- The first entry in the Ancestors_Tags array will be null for such
839 -- a type, but it's better to be explicit about returning No_Tag in
842 if TSD
.Idepth
= 0 then
845 return TSD
.Tags_Table
(1);
849 -------------------------------
850 -- Register_Interface_Offset --
851 -------------------------------
853 procedure Register_Interface_Offset
854 (This
: System
.Address
;
857 Offset_Value
: SSE
.Storage_Offset
;
858 Offset_Func
: Offset_To_Top_Function_Ptr
)
860 Prim_DT
: Dispatch_Table_Ptr
;
861 Iface_Table
: Interface_Data_Ptr
;
864 -- "This" points to the primary DT and we must save Offset_Value in
865 -- the Offset_To_Top field of the corresponding dispatch table.
867 Prim_DT
:= DT
(To_Tag_Ptr
(This
).all);
868 Iface_Table
:= To_Type_Specific_Data_Ptr
(Prim_DT
.TSD
).Interfaces_Table
;
870 -- Save Offset_Value in the table of interfaces of the primary DT.
871 -- This data will be used by the subprogram "Displace" to give support
872 -- to backward abstract interface type conversions.
874 -- Register the offset in the table of interfaces
876 if Iface_Table
/= null then
877 for Id
in 1 .. Iface_Table
.Nb_Ifaces
loop
878 if Iface_Table
.Ifaces_Table
(Id
).Iface_Tag
= Interface_T
then
879 if Is_Static
or else Offset_Value
= 0 then
880 Iface_Table
.Ifaces_Table
(Id
).Static_Offset_To_Top
:= True;
881 Iface_Table
.Ifaces_Table
(Id
).Offset_To_Top_Value
:=
884 Iface_Table
.Ifaces_Table
(Id
).Static_Offset_To_Top
:= False;
885 Iface_Table
.Ifaces_Table
(Id
).Offset_To_Top_Func
:=
894 -- If we arrive here there is some error in the run-time data structure
897 end Register_Interface_Offset
;
903 procedure Register_Tag
(T
: Tag
) is
905 External_Tag_HTable
.Set
(T
);
912 function Secondary_Tag
(T
, Iface
: Tag
) return Tag
is
913 Iface_Table
: Interface_Data_Ptr
;
914 Obj_DT
: Dispatch_Table_Ptr
;
917 if not Is_Primary_DT
(T
) then
922 Iface_Table
:= To_Type_Specific_Data_Ptr
(Obj_DT
.TSD
).Interfaces_Table
;
924 if Iface_Table
/= null then
925 for Id
in 1 .. Iface_Table
.Nb_Ifaces
loop
926 if Iface_Table
.Ifaces_Table
(Id
).Iface_Tag
= Iface
then
927 return Iface_Table
.Ifaces_Table
(Id
).Secondary_DT
;
932 -- If the object does not implement the interface we must raise CE
934 raise Constraint_Error
with "invalid interface conversion";
937 ---------------------
938 -- Set_Entry_Index --
939 ---------------------
941 procedure Set_Entry_Index
947 SSD
(T
).SSD_Table
(Position
).Index
:= Value
;
950 -----------------------
951 -- Set_Offset_To_Top --
952 -----------------------
954 procedure Set_Dynamic_Offset_To_Top
955 (This
: System
.Address
;
957 Offset_Value
: SSE
.Storage_Offset
;
958 Offset_Func
: Offset_To_Top_Function_Ptr
)
960 Sec_Base
: System
.Address
;
961 Sec_DT
: Dispatch_Table_Ptr
;
963 -- Save the offset to top field in the secondary dispatch table
965 if Offset_Value
/= 0 then
966 Sec_Base
:= This
+ Offset_Value
;
967 Sec_DT
:= DT
(To_Tag_Ptr
(Sec_Base
).all);
968 Sec_DT
.Offset_To_Top
:= SSE
.Storage_Offset
'Last;
971 Register_Interface_Offset
972 (This
, Interface_T
, False, Offset_Value
, Offset_Func
);
973 end Set_Dynamic_Offset_To_Top
;
975 ----------------------
976 -- Set_Prim_Op_Kind --
977 ----------------------
979 procedure Set_Prim_Op_Kind
982 Value
: Prim_Op_Kind
)
985 SSD
(T
).SSD_Table
(Position
).Kind
:= Value
;
986 end Set_Prim_Op_Kind
;
988 ----------------------
989 -- Type_Is_Abstract --
990 ----------------------
992 function Type_Is_Abstract
(T
: Tag
) return Boolean is
994 TSD
: Type_Specific_Data_Ptr
;
1001 TSD_Ptr
:= To_Addr_Ptr
(To_Address
(T
) - DT_Typeinfo_Ptr_Size
);
1002 TSD
:= To_Type_Specific_Data_Ptr
(TSD_Ptr
.all);
1003 return TSD
.Type_Is_Abstract
;
1004 end Type_Is_Abstract
;
1006 --------------------
1007 -- Unregister_Tag --
1008 --------------------
1010 procedure Unregister_Tag
(T
: Tag
) is
1012 External_Tag_HTable
.Remove
(Get_External_Tag
(T
));
1015 ------------------------
1016 -- Wide_Expanded_Name --
1017 ------------------------
1019 WC_Encoding
: Character;
1020 pragma Import
(C
, WC_Encoding
, "__gl_wc_encoding");
1021 -- Encoding method for source, as exported by binder
1023 function Wide_Expanded_Name
(T
: Tag
) return Wide_String is
1024 S
: constant String := Expanded_Name
(T
);
1025 W
: Wide_String (1 .. S
'Length);
1028 String_To_Wide_String
1029 (S
, W
, L
, Get_WC_Encoding_Method
(WC_Encoding
));
1031 end Wide_Expanded_Name
;
1033 -----------------------------
1034 -- Wide_Wide_Expanded_Name --
1035 -----------------------------
1037 function Wide_Wide_Expanded_Name
(T
: Tag
) return Wide_Wide_String
is
1038 S
: constant String := Expanded_Name
(T
);
1039 W
: Wide_Wide_String
(1 .. S
'Length);
1042 String_To_Wide_Wide_String
1043 (S
, W
, L
, Get_WC_Encoding_Method
(WC_Encoding
));
1045 end Wide_Wide_Expanded_Name
;