1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
9 -- Copyright (C) 1992-2006, 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
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 -- Structure of the GNAT Primary Dispatch Table
46 -- +----------------------+
48 -- : predefined primitive :
50 -- +----------------------+
52 -- +----------------------+
54 -- +----------------------+
56 -- +----------------------+
57 -- | Typeinfo_Ptr/TSD_Ptr ---> Type Specific Data
58 -- Tag ---> +----------------------+ +-------------------+
59 -- | table of | | inheritance depth |
60 -- : primitive ops : +-------------------+
61 -- | pointers | | access level |
62 -- +----------------------+ +-------------------+
64 -- +-------------------+
66 -- +-------------------+
67 -- | hash table link |
68 -- +-------------------+
69 -- | remotely callable |
70 -- +-------------------+
71 -- | rec ctrler offset |
72 -- +-------------------+
74 -- +-------------------+
75 -- | Ifaces_Table_Ptr --> Interface Data
76 -- +-------------------+ +------------+
77 -- Select Specific Data <---- SSD_Ptr | | table |
78 -- +--------------------+ +-------------------+ : of :
79 -- | table of primitive | | table of | | interfaces |
80 -- : operation : : ancestor : +------------+
82 -- +--------------------+ +-------------------+
86 -- +--------------------+
88 -- Structure of the GNAT Secondary Dispatch Table
90 -- +-----------------------+
92 -- : predefined primitive :
94 -- +-----------------------+
96 -- +-----------------------+
98 -- +-----------------------+
100 -- +-----------------------+
101 -- | OSD_Ptr |---> Object Specific Data
102 -- Tag ---> +-----------------------+ +---------------+
103 -- | table of | | num prim ops |
104 -- : primitive op : +---------------+
105 -- | thunk pointers | | table of |
106 -- +-----------------------+ + primitive |
110 ----------------------------------
111 -- GNAT Dispatch Table Prologue --
112 ----------------------------------
114 -- GNAT's Dispatch Table prologue contains several fields which are hidden
115 -- in order to preserve compatibility with C++. These fields are accessed
116 -- by address calculations performed in the following manner:
118 -- Field : Field_Type :=
119 -- (To_Address (Tag) - Sum_Of_Preceding_Field_Sizes).all;
121 -- The bracketed subtraction shifts the pointer (Tag) from the table of
122 -- primitive operations (or thunks) to the field in question. Since the
123 -- result of the subtraction is an address, dereferencing it will obtain
124 -- the actual value of the field.
126 -- Guidelines for addition of new hidden fields
128 -- Define a Field_Type and Field_Type_Ptr (access to Field_Type) in
129 -- A-Tags.ads for the newly introduced field.
131 -- Defined the size of the new field as a constant Field_Name_Size
133 -- Introduce an Unchecked_Conversion from System.Address to
134 -- Field_Type_Ptr in A-Tags.ads.
136 -- Define the specifications of Get_<Field_Name> and Set_<Field_Name>
139 -- Update the GNAT Dispatch Table structure in a-tags.adb
141 -- Provide bodies to the Get_<Field_Name> and Set_<Field_Name> routines.
142 -- The profile of a Get_<Field_Name> routine should resemble:
144 -- function Get_<Field_Name> (T : Tag; ...) return Field_Type is
145 -- Field : constant System.Address :=
146 -- To_Address (T) - <Sum_Of_Previous_Field_Sizes>;
148 -- pragma Assert (Check_Signature (T, <Applicable_DT>));
149 -- <Additional_Assertions>
151 -- return To_Field_Type_Ptr (Field).all;
152 -- end Get_<Field_Name>;
154 -- The profile of a Set_<Field_Name> routine should resemble:
156 -- procedure Set_<Field_Name> (T : Tag; ..., Value : Field_Type) is
157 -- Field : constant System.Address :=
158 -- To_Address (T) - <Sum_Of_Previous_Field_Sizes>;
160 -- pragma Assert (Check_Signature (T, <Applicable_DT>));
161 -- <Additional_Assertions>
163 -- To_Field_Type_Ptr (Field).all := Value;
164 -- end Set_<Field_Name>;
166 -- NOTE: For each field in the prologue which precedes the newly added
167 -- one, find and update its respective Sum_Of_Previous_Field_Sizes by
168 -- subtractind Field_Name_Size from it. Falure to do so will clobber the
169 -- previous prologue field.
171 K_Typeinfo
: constant SSE
.Storage_Count
:= DT_Typeinfo_Ptr_Size
;
173 K_Offset_To_Top
: constant SSE
.Storage_Count
:=
174 K_Typeinfo
+ DT_Offset_To_Top_Size
;
176 K_Tagged_Kind
: constant SSE
.Storage_Count
:=
177 K_Offset_To_Top
+ DT_Tagged_Kind_Size
;
179 K_Signature
: constant SSE
.Storage_Count
:=
180 K_Tagged_Kind
+ DT_Signature_Size
;
182 subtype Cstring
is String (Positive);
183 type Cstring_Ptr
is access all Cstring
;
185 -- We suppress index checks because the declared size in the record below
186 -- is a dummy size of one (see below).
188 type Tag_Table
is array (Natural range <>) of Tag
;
189 pragma Suppress_Initialization
(Tag_Table
);
190 pragma Suppress
(Index_Check
, On
=> Tag_Table
);
192 -- Declarations for the table of interfaces
194 type Interface_Data_Element
is record
196 Static_Offset_To_Top
: Boolean;
197 Offset_To_Top_Value
: System
.Storage_Elements
.Storage_Offset
;
198 Offset_To_Top_Func
: System
.Address
;
200 -- If some ancestor of the tagged type has discriminants the field
201 -- Static_Offset_To_Top is False and the field Offset_To_Top_Func
202 -- is used to store the address of the function generated by the
203 -- expander which provides this value; otherwise Static_Offset_To_Top
204 -- is True and such value is stored in the Offset_To_Top_Value field.
206 type Interfaces_Array
is
207 array (Natural range <>) of Interface_Data_Element
;
209 type Interface_Data
(Nb_Ifaces
: Positive) is record
210 Table
: Interfaces_Array
(1 .. Nb_Ifaces
);
213 -- Object specific data types
215 type Object_Specific_Data_Array
is array (Positive range <>) of Positive;
217 type Object_Specific_Data
(Nb_Prim
: Positive) is record
218 Num_Prim_Ops
: Natural;
219 -- Number of primitive operations of the dispatch table. This field is
220 -- used by the run-time check routines that are activated when the
221 -- run-time is compiled with assertions enabled.
223 OSD_Table
: Object_Specific_Data_Array
(1 .. Nb_Prim
);
224 -- Table used in secondary DT to reference their counterpart in the
225 -- select specific data (in the TSD of the primary DT). This construct
226 -- is used in the handling of dispatching triggers in select statements.
227 -- Nb_Prim is the number of non-predefined primitive operations.
230 -- Select specific data types
232 type Select_Specific_Data_Element
is record
237 type Select_Specific_Data_Array
is
238 array (Positive range <>) of Select_Specific_Data_Element
;
240 type Select_Specific_Data
(Nb_Prim
: Positive) is record
241 SSD_Table
: Select_Specific_Data_Array
(1 .. Nb_Prim
);
242 -- NOTE: Nb_Prim is the number of non-predefined primitive operations
245 -- Type specific data types
247 type Type_Specific_Data
is record
249 -- Inheritance Depth Level: Used to implement the membership test
250 -- associated with single inheritance of tagged types in constant-time.
251 -- In addition it also indicates the size of the first table stored in
252 -- the Tags_Table component (see comment below).
254 Access_Level
: Natural;
255 -- Accessibility level required to give support to Ada 2005 nested type
256 -- extensions. This feature allows safe nested type extensions by
257 -- shifting the accessibility checks to certain operations, rather than
258 -- being enforced at the type declaration. In particular, by performing
259 -- run-time accessibility checks on class-wide allocators, class-wide
260 -- function return, and class-wide stream I/O, the danger of objects
261 -- outliving their type declaration can be eliminated (Ada 2005: AI-344)
263 Expanded_Name
: Cstring_Ptr
;
264 External_Tag
: Cstring_Ptr
;
266 -- Components used to give support to the Ada.Tags subprograms described
269 Remotely_Callable
: Boolean;
270 -- Used to check ARM E.4 (18)
272 RC_Offset
: SSE
.Storage_Offset
;
273 -- Controller Offset: Used to give support to tagged controlled objects
274 -- (see Get_Deep_Controller at s-finimp)
276 Ifaces_Table_Ptr
: System
.Address
;
277 -- Pointer to the table of interface tags. It is used to implement the
278 -- membership test associated with interfaces and also for backward
279 -- abstract interface type conversions (Ada 2005:AI-251)
281 Num_Prim_Ops
: Natural;
282 -- Number of primitive operations of the dispatch table. This field is
283 -- used for additional run-time checks when the run-time is compiled
284 -- with assertions enabled.
286 SSD_Ptr
: System
.Address
;
287 -- Pointer to a table of records used in dispatching selects. This
288 -- field has a meaningful value for all tagged types that implement
289 -- a limited, protected, synchronized or task interfaces and have
290 -- non-predefined primitive operations.
292 Tags_Table
: Tag_Table
(0 .. 1);
293 -- The size of the Tags_Table array actually depends on the tagged type
294 -- to which it applies. The compiler ensures that has enough space to
295 -- store all the entries of the two tables phisically stored there: the
296 -- "table of ancestor tags" and the "table of interface tags". For this
297 -- purpose we are using the same mechanism as for the Prims_Ptr array in
298 -- the Dispatch_Table record. See comments below on Prims_Ptr for
302 type Dispatch_Table
is record
304 -- According to the C++ ABI the components Offset_To_Top and
305 -- Typeinfo_Ptr are stored just "before" the dispatch table (that is,
306 -- the Prims_Ptr table), and they are referenced with negative offsets
307 -- referring to the base of the dispatch table. The _Tag (or the
308 -- VTable_Ptr in C++ terminology) must point to the base of the virtual
309 -- table, just after these components, to point to the Prims_Ptr table.
310 -- For this purpose the expander generates a Prims_Ptr table that has
311 -- enough space for these additional components, and generates code that
312 -- displaces the _Tag to point after these components.
314 -- Signature : Signature_Kind;
315 -- Tagged_Kind : Tagged_Kind;
316 -- Offset_To_Top : Natural;
317 -- Typeinfo_Ptr : System.Address;
319 Prims_Ptr
: Address_Array
(1 .. 1);
320 -- The size of the Prims_Ptr array actually depends on the tagged type
321 -- to which it applies. For each tagged type, the expander computes the
322 -- actual array size, allocates the Dispatch_Table record accordingly,
323 -- and generates code that displaces the base of the record after the
324 -- Typeinfo_Ptr component. For this reason the first two components have
325 -- been commented in the previous declaration. The access to these
326 -- components is done by means of local functions.
328 -- To avoid the use of discriminants to define the actual size of the
329 -- dispatch table, we used to declare the tag as a pointer to a record
330 -- that contains an arbitrary array of addresses, using Positive as its
331 -- index. This ensures that there are never range checks when accessing
332 -- the dispatch table, but it prevents GDB from displaying tagged types
333 -- properly. A better approach is to declare this record type as holding
334 -- small number of addresses, and to explicitly suppress checks on it.
336 -- Note that in both cases, this type is never allocated, and serves
337 -- only to declare the corresponding access type.
340 type Signature_Type
is
342 Must_Be_Secondary_DT
,
343 Must_Be_Primary_Or_Secondary_DT
,
345 Must_Be_Primary_Or_Interface
);
346 -- Type of signature accepted by primitives in this package that are called
347 -- during the elaboration of tagged types. This type is used by the routine
348 -- Check_Signature that is called only when the run-time is compiled with
349 -- assertions enabled.
351 ---------------------------------------------
352 -- Unchecked Conversions for String Fields --
353 ---------------------------------------------
355 function To_Address
is
356 new Unchecked_Conversion
(Cstring_Ptr
, System
.Address
);
358 function To_Cstring_Ptr
is
359 new Unchecked_Conversion
(System
.Address
, Cstring_Ptr
);
361 ------------------------------------------------
362 -- Unchecked Conversions for other components --
363 ------------------------------------------------
366 is access function (A
: System
.Address
) return Long_Long_Integer;
368 function To_Acc_Size
is new Unchecked_Conversion
(System
.Address
, Acc_Size
);
369 -- The profile of the implicitly defined _size primitive
371 type Offset_To_Top_Function_Ptr
is
372 access function (This
: System
.Address
)
373 return System
.Storage_Elements
.Storage_Offset
;
374 -- Type definition used to call the function that is generated by the
375 -- expander in case of tagged types with discriminants that have secondary
376 -- dispatch tables. This function provides the Offset_To_Top value in this
379 function To_Offset_To_Top_Function_Ptr
is
380 new Unchecked_Conversion
(System
.Address
, Offset_To_Top_Function_Ptr
);
382 type Storage_Offset_Ptr
is access System
.Storage_Elements
.Storage_Offset
;
384 function To_Storage_Offset_Ptr
is
385 new Unchecked_Conversion
(System
.Address
, Storage_Offset_Ptr
);
387 -----------------------
388 -- Local Subprograms --
389 -----------------------
391 function Check_Signature
(T
: Tag
; Kind
: Signature_Type
) return Boolean;
392 -- Check that the signature of T is valid and corresponds with the subset
393 -- specified by the signature Kind.
398 Entry_Count
: Natural) return Boolean;
399 -- Verify that Old_T and New_T have at least Entry_Count entries
401 function Get_Num_Prim_Ops
(T
: Tag
) return Natural;
402 -- Retrieve the number of primitive operations in the dispatch table of T
404 function Is_Primary_DT
(T
: Tag
) return Boolean;
405 pragma Inline_Always
(Is_Primary_DT
);
406 -- Given a tag returns True if it has the signature of a primary dispatch
407 -- table. This is Inline_Always since it is called from other Inline_
408 -- Always subprograms where we want no out of line code to be generated.
410 function Length
(Str
: Cstring_Ptr
) return Natural;
411 -- Length of string represented by the given pointer (treating the string
412 -- as a C-style string, which is Nul terminated).
414 function Predefined_DT
(T
: Tag
) return Tag
;
415 pragma Inline_Always
(Predefined_DT
);
416 -- Displace the Tag to reference the dispatch table containing the
417 -- predefined primitives.
419 function Typeinfo_Ptr
(T
: Tag
) return System
.Address
;
420 -- Returns the current value of the typeinfo_ptr component available in
421 -- the prologue of the dispatch table.
423 pragma Unreferenced
(Typeinfo_Ptr
);
424 -- These functions will be used for full compatibility with the C++ ABI
426 -------------------------
427 -- External_Tag_HTable --
428 -------------------------
430 type HTable_Headers
is range 1 .. 64;
432 -- The following internal package defines the routines used for the
433 -- instantiation of a new System.HTable.Static_HTable (see below). See
434 -- spec in g-htable.ads for details of usage.
436 package HTable_Subprograms
is
437 procedure Set_HT_Link
(T
: Tag
; Next
: Tag
);
438 function Get_HT_Link
(T
: Tag
) return Tag
;
439 function Hash
(F
: System
.Address
) return HTable_Headers
;
440 function Equal
(A
, B
: System
.Address
) return Boolean;
441 end HTable_Subprograms
;
443 package External_Tag_HTable
is new System
.HTable
.Static_HTable
(
444 Header_Num
=> HTable_Headers
,
445 Element
=> Dispatch_Table
,
448 Set_Next
=> HTable_Subprograms
.Set_HT_Link
,
449 Next
=> HTable_Subprograms
.Get_HT_Link
,
450 Key
=> System
.Address
,
451 Get_Key
=> Get_External_Tag
,
452 Hash
=> HTable_Subprograms
.Hash
,
453 Equal
=> HTable_Subprograms
.Equal
);
455 ------------------------
456 -- HTable_Subprograms --
457 ------------------------
459 -- Bodies of routines for hash table instantiation
461 package body HTable_Subprograms
is
467 function Equal
(A
, B
: System
.Address
) return Boolean is
468 Str1
: constant Cstring_Ptr
:= To_Cstring_Ptr
(A
);
469 Str2
: constant Cstring_Ptr
:= To_Cstring_Ptr
(B
);
473 if Str1
(J
) /= Str2
(J
) then
475 elsif Str1
(J
) = ASCII
.NUL
then
487 function Get_HT_Link
(T
: Tag
) return Tag
is
489 return TSD
(T
).HT_Link
;
496 function Hash
(F
: System
.Address
) return HTable_Headers
is
497 function H
is new System
.HTable
.Hash
(HTable_Headers
);
498 Str
: constant Cstring_Ptr
:= To_Cstring_Ptr
(F
);
499 Res
: constant HTable_Headers
:= H
(Str
(1 .. Length
(Str
)));
508 procedure Set_HT_Link
(T
: Tag
; Next
: Tag
) is
510 TSD
(T
).HT_Link
:= Next
;
513 end HTable_Subprograms
;
515 ---------------------
516 -- Check_Signature --
517 ---------------------
519 function Check_Signature
(T
: Tag
; Kind
: Signature_Type
) return Boolean is
520 Signature
: constant Storage_Offset_Ptr
:=
521 To_Storage_Offset_Ptr
(To_Address
(T
) - K_Signature
);
523 Sig_Values
: constant Signature_Values
:=
524 To_Signature_Values
(Signature
.all);
526 Signature_Id
: Signature_Kind
;
529 if Sig_Values
(1) /= Valid_Signature
then
530 Signature_Id
:= Unknown
;
532 elsif Sig_Values
(2) in Primary_DT
.. Abstract_Interface
then
533 Signature_Id
:= Sig_Values
(2);
536 Signature_Id
:= Unknown
;
541 if Kind
= Must_Be_Secondary_DT
542 or else Kind
= Must_Be_Interface
548 if Kind
= Must_Be_Primary_DT
549 or else Kind
= Must_Be_Interface
554 when Abstract_Interface
=>
555 if Kind
= Must_Be_Primary_DT
556 or else Kind
= Must_Be_Secondary_DT
557 or else Kind
= Must_Be_Primary_Or_Secondary_DT
577 Entry_Count
: Natural) return Boolean
579 Max_Entries_Old
: constant Natural := Get_Num_Prim_Ops
(Old_T
);
580 Max_Entries_New
: constant Natural := Get_Num_Prim_Ops
(New_T
);
583 return Entry_Count
<= Max_Entries_Old
584 and then Entry_Count
<= Max_Entries_New
;
591 -- Canonical implementation of Classwide Membership corresponding to:
595 -- Each dispatch table contains a reference to a table of ancestors (stored
596 -- in the first part of the Tags_Table) and a count of the level of
597 -- inheritance "Idepth".
599 -- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
600 -- contained in the dispatch table referenced by Obj'Tag . Knowing the
601 -- level of inheritance of both types, this can be computed in constant
602 -- time by the formula:
604 -- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
607 function CW_Membership
(Obj_Tag
: Tag
; Typ_Tag
: Tag
) return Boolean is
610 pragma Assert
(Check_Signature
(Obj_Tag
, Must_Be_Primary_DT
));
611 pragma Assert
(Check_Signature
(Typ_Tag
, Must_Be_Primary_DT
));
612 Pos
:= TSD
(Obj_Tag
).Idepth
- TSD
(Typ_Tag
).Idepth
;
613 return Pos
>= 0 and then TSD
(Obj_Tag
).Tags_Table
(Pos
) = Typ_Tag
;
621 (This
: System
.Address
;
622 T
: Tag
) return System
.Address
624 Curr_DT
: constant Tag
:= To_Tag_Ptr
(This
).all;
625 Iface_Table
: Interface_Data_Ptr
;
626 Obj_Base
: System
.Address
;
628 Obj_TSD
: Type_Specific_Data_Ptr
;
632 (Check_Signature
(Curr_DT
, Must_Be_Primary_Or_Secondary_DT
));
634 (Check_Signature
(T
, Must_Be_Interface
));
636 Obj_Base
:= This
- Offset_To_Top
(This
);
637 Obj_DT
:= To_Tag_Ptr
(Obj_Base
).all;
640 (Check_Signature
(Obj_DT
, Must_Be_Primary_DT
));
642 Obj_TSD
:= TSD
(Obj_DT
);
643 Iface_Table
:= To_Interface_Data_Ptr
(Obj_TSD
.Ifaces_Table_Ptr
);
645 if Iface_Table
/= null then
646 for Id
in 1 .. Iface_Table
.Nb_Ifaces
loop
647 if Iface_Table
.Table
(Id
).Iface_Tag
= T
then
649 -- Case of Static value of Offset_To_Top
651 if Iface_Table
.Table
(Id
).Static_Offset_To_Top
then
653 Obj_Base
+ Iface_Table
.Table
(Id
).Offset_To_Top_Value
;
655 -- Otherwise we call the function generated by the expander
656 -- to provide us with this value
661 To_Offset_To_Top_Function_Ptr
662 (Iface_Table
.Table
(Id
).Offset_To_Top_Func
).all
666 Obj_DT
:= To_Tag_Ptr
(Obj_Base
).all;
669 (Check_Signature
(Obj_DT
, Must_Be_Secondary_DT
));
676 -- Check if T is an immediate ancestor. This is required to handle
677 -- conversion of class-wide interfaces to tagged types.
679 if CW_Membership
(Obj_DT
, T
) then
683 -- If the object does not implement the interface we must raise CE
685 raise Constraint_Error
;
692 -- Canonical implementation of Classwide Membership corresponding to:
694 -- Obj in Iface'Class
696 -- Each dispatch table contains a table with the tags of all the
697 -- implemented interfaces.
699 -- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
700 -- that are contained in the dispatch table referenced by Obj'Tag.
702 function IW_Membership
(This
: System
.Address
; T
: Tag
) return Boolean is
703 Curr_DT
: constant Tag
:= To_Tag_Ptr
(This
).all;
704 Iface_Table
: Interface_Data_Ptr
;
706 Obj_Base
: System
.Address
;
708 Obj_TSD
: Type_Specific_Data_Ptr
;
712 (Check_Signature
(Curr_DT
, Must_Be_Primary_Or_Secondary_DT
));
714 (Check_Signature
(T
, Must_Be_Primary_Or_Interface
));
716 Obj_Base
:= This
- Offset_To_Top
(This
);
717 Obj_DT
:= To_Tag_Ptr
(Obj_Base
).all;
720 (Check_Signature
(Obj_DT
, Must_Be_Primary_DT
));
722 Obj_TSD
:= TSD
(Obj_DT
);
723 Last_Id
:= Obj_TSD
.Idepth
;
725 -- Look for the tag in the table of interfaces
727 Iface_Table
:= To_Interface_Data_Ptr
(Obj_TSD
.Ifaces_Table_Ptr
);
729 if Iface_Table
/= null then
730 for Id
in 1 .. Iface_Table
.Nb_Ifaces
loop
731 if Iface_Table
.Table
(Id
).Iface_Tag
= T
then
737 -- Look for the tag in the ancestor tags table. This is required for:
738 -- Iface_CW in Typ'Class
740 for Id
in 0 .. Last_Id
loop
741 if Obj_TSD
.Tags_Table
(Id
) = T
then
753 function Descendant_Tag
(External
: String; Ancestor
: Tag
) return Tag
is
757 pragma Assert
(Check_Signature
(Ancestor
, Must_Be_Primary_DT
));
758 Int_Tag
:= Internal_Tag
(External
);
759 pragma Assert
(Check_Signature
(Int_Tag
, Must_Be_Primary_DT
));
761 if not Is_Descendant_At_Same_Level
(Int_Tag
, Ancestor
) then
772 function Expanded_Name
(T
: Tag
) return String is
773 Result
: Cstring_Ptr
;
780 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Interface
));
781 Result
:= TSD
(T
).Expanded_Name
;
782 return Result
(1 .. Length
(Result
));
789 function External_Tag
(T
: Tag
) return String is
790 Result
: Cstring_Ptr
;
797 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Interface
));
798 Result
:= TSD
(T
).External_Tag
;
800 return Result
(1 .. Length
(Result
));
803 ----------------------
804 -- Get_Access_Level --
805 ----------------------
807 function Get_Access_Level
(T
: Tag
) return Natural is
809 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
810 return TSD
(T
).Access_Level
;
811 end Get_Access_Level
;
813 ---------------------
814 -- Get_Entry_Index --
815 ---------------------
817 function Get_Entry_Index
(T
: Tag
; Position
: Positive) return Positive is
819 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
820 pragma Assert
(Position
<= Get_Num_Prim_Ops
(T
));
821 return SSD
(T
).SSD_Table
(Position
).Index
;
824 ----------------------
825 -- Get_External_Tag --
826 ----------------------
828 function Get_External_Tag
(T
: Tag
) return System
.Address
is
830 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
831 return To_Address
(TSD
(T
).External_Tag
);
832 end Get_External_Tag
;
834 ----------------------
835 -- Get_Num_Prim_Ops --
836 ----------------------
838 function Get_Num_Prim_Ops
(T
: Tag
) return Natural is
840 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Secondary_DT
));
842 if Is_Primary_DT
(T
) then
843 return TSD
(T
).Num_Prim_Ops
;
845 return OSD
(T
).Num_Prim_Ops
;
847 end Get_Num_Prim_Ops
;
849 --------------------------------
850 -- Get_Predef_Prim_Op_Address --
851 --------------------------------
853 function Get_Predefined_Prim_Op_Address
855 Position
: Positive) return System
.Address
858 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Secondary_DT
));
859 pragma Assert
(Position
<= Default_Prim_Op_Count
);
860 return Predefined_DT
(T
).Prims_Ptr
(Position
);
861 end Get_Predefined_Prim_Op_Address
;
863 -------------------------
864 -- Get_Prim_Op_Address --
865 -------------------------
867 function Get_Prim_Op_Address
869 Position
: Positive) return System
.Address
872 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Secondary_DT
));
873 pragma Assert
(Position
<= Get_Num_Prim_Ops
(T
));
874 return T
.Prims_Ptr
(Position
);
875 end Get_Prim_Op_Address
;
877 ----------------------
878 -- Get_Prim_Op_Kind --
879 ----------------------
881 function Get_Prim_Op_Kind
883 Position
: Positive) return Prim_Op_Kind
886 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
887 pragma Assert
(Position
<= Get_Num_Prim_Ops
(T
));
888 return SSD
(T
).SSD_Table
(Position
).Kind
;
889 end Get_Prim_Op_Kind
;
891 ----------------------
892 -- Get_Offset_Index --
893 ----------------------
895 function Get_Offset_Index
897 Position
: Positive) return Positive
900 pragma Assert
(Check_Signature
(T
, Must_Be_Secondary_DT
));
901 pragma Assert
(Position
<= Get_Num_Prim_Ops
(T
));
902 return OSD
(T
).OSD_Table
(Position
);
903 end Get_Offset_Index
;
909 function Get_RC_Offset
(T
: Tag
) return SSE
.Storage_Offset
is
911 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
912 return TSD
(T
).RC_Offset
;
915 ---------------------------
916 -- Get_Remotely_Callable --
917 ---------------------------
919 function Get_Remotely_Callable
(T
: Tag
) return Boolean is
921 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
922 return TSD
(T
).Remotely_Callable
;
923 end Get_Remotely_Callable
;
925 ---------------------
926 -- Get_Tagged_Kind --
927 ---------------------
929 function Get_Tagged_Kind
(T
: Tag
) return Tagged_Kind
is
930 Tagged_Kind_Ptr
: constant System
.Address
:=
931 To_Address
(T
) - K_Tagged_Kind
;
933 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Secondary_DT
));
934 return To_Tagged_Kind_Ptr
(Tagged_Kind_Ptr
).all;
941 procedure Inherit_CPP_DT
944 Entry_Count
: Natural)
947 New_T
.Prims_Ptr
(1 .. Entry_Count
) := Old_T
.Prims_Ptr
(1 .. Entry_Count
);
954 procedure Inherit_DT
(Old_T
: Tag
; New_T
: Tag
; Entry_Count
: Natural) is
955 subtype All_Predefined_Prims
is
956 Positive range 1 .. Default_Prim_Op_Count
;
959 pragma Assert
(Check_Signature
(Old_T
, Must_Be_Primary_Or_Secondary_DT
));
960 pragma Assert
(Check_Signature
(New_T
, Must_Be_Primary_Or_Secondary_DT
));
961 pragma Assert
(Check_Size
(Old_T
, New_T
, Entry_Count
));
963 if Old_T
/= null then
965 -- Inherit the primitives of the parent
967 New_T
.Prims_Ptr
(1 .. Entry_Count
) :=
968 Old_T
.Prims_Ptr
(1 .. Entry_Count
);
970 -- Inherit the predefined primitives of the parent
972 -- NOTE: In the following assignment we have to unactivate a warning
973 -- generated by the compiler because of the following declaration of
974 -- the Dispatch_Table:
976 -- Prims_Ptr : Address_Array (1 .. 1);
978 -- This is a dummy declaration that is expanded by the frontend to
979 -- the correct size of the dispatch table corresponding with each
980 -- tagged type. As a consequence, if we try to use a constant to
981 -- copy the predefined elements (ie. Prims_Ptr (1 .. 15) := ...)
982 -- the compiler generates a warning indicating that Constraint_Error
983 -- will be raised at run-time (which is not true in this specific
986 pragma Warnings
(Off
);
987 Predefined_DT
(New_T
).Prims_Ptr
(All_Predefined_Prims
) :=
988 Predefined_DT
(Old_T
).Prims_Ptr
(All_Predefined_Prims
);
989 pragma Warnings
(On
);
997 procedure Inherit_TSD
(Old_Tag
: Tag
; New_Tag
: Tag
) is
998 New_TSD_Ptr
: Type_Specific_Data_Ptr
;
999 New_Iface_Table_Ptr
: Interface_Data_Ptr
;
1000 Old_TSD_Ptr
: Type_Specific_Data_Ptr
;
1001 Old_Iface_Table_Ptr
: Interface_Data_Ptr
;
1004 pragma Assert
(Check_Signature
(New_Tag
, Must_Be_Primary_Or_Interface
));
1005 New_TSD_Ptr
:= TSD
(New_Tag
);
1007 if Old_Tag
/= null then
1009 (Check_Signature
(Old_Tag
, Must_Be_Primary_Or_Interface
));
1010 Old_TSD_Ptr
:= TSD
(Old_Tag
);
1011 New_TSD_Ptr
.Idepth
:= Old_TSD_Ptr
.Idepth
+ 1;
1013 -- Copy the "table of ancestor tags" plus the "table of interfaces"
1016 New_TSD_Ptr
.Tags_Table
(1 .. New_TSD_Ptr
.Idepth
) :=
1017 Old_TSD_Ptr
.Tags_Table
(0 .. Old_TSD_Ptr
.Idepth
);
1019 -- Copy the table of interfaces of the parent
1021 if not System
."=" (Old_TSD_Ptr
.Ifaces_Table_Ptr
,
1022 System
.Null_Address
)
1024 Old_Iface_Table_Ptr
:=
1025 To_Interface_Data_Ptr
(Old_TSD_Ptr
.Ifaces_Table_Ptr
);
1026 New_Iface_Table_Ptr
:=
1027 To_Interface_Data_Ptr
(New_TSD_Ptr
.Ifaces_Table_Ptr
);
1029 New_Iface_Table_Ptr
.Table
(1 .. Old_Iface_Table_Ptr
.Nb_Ifaces
) :=
1030 Old_Iface_Table_Ptr
.Table
(1 .. Old_Iface_Table_Ptr
.Nb_Ifaces
);
1034 New_TSD_Ptr
.Idepth
:= 0;
1037 New_TSD_Ptr
.Tags_Table
(0) := New_Tag
;
1040 -----------------------------
1041 -- Interface_Ancestor_Tags --
1042 -----------------------------
1044 function Interface_Ancestor_Tags
(T
: Tag
) return Tag_Array
is
1045 Iface_Table
: Interface_Data_Ptr
;
1048 Iface_Table
:= To_Interface_Data_Ptr
(TSD
(T
).Ifaces_Table_Ptr
);
1050 if Iface_Table
= null then
1052 Table
: Tag_Array
(1 .. 0);
1058 Table
: Tag_Array
(1 .. Iface_Table
.Nb_Ifaces
);
1060 for J
in 1 .. Iface_Table
.Nb_Ifaces
loop
1061 Table
(J
) := Iface_Table
.Table
(J
).Iface_Tag
;
1067 end Interface_Ancestor_Tags
;
1073 function Internal_Tag
(External
: String) return Tag
is
1074 Ext_Copy
: aliased String (External
'First .. External
'Last + 1);
1078 -- Make a copy of the string representing the external tag with
1079 -- a null at the end.
1081 Ext_Copy
(External
'Range) := External
;
1082 Ext_Copy
(Ext_Copy
'Last) := ASCII
.NUL
;
1083 Res
:= External_Tag_HTable
.Get
(Ext_Copy
'Address);
1087 Msg1
: constant String := "unknown tagged type: ";
1088 Msg2
: String (1 .. Msg1
'Length + External
'Length);
1091 Msg2
(1 .. Msg1
'Length) := Msg1
;
1092 Msg2
(Msg1
'Length + 1 .. Msg1
'Length + External
'Length) :=
1094 Ada
.Exceptions
.Raise_Exception
(Tag_Error
'Identity, Msg2
);
1101 ---------------------------------
1102 -- Is_Descendant_At_Same_Level --
1103 ---------------------------------
1105 function Is_Descendant_At_Same_Level
1107 Ancestor
: Tag
) return Boolean
1110 return CW_Membership
(Descendant
, Ancestor
)
1111 and then TSD
(Descendant
).Access_Level
= TSD
(Ancestor
).Access_Level
;
1112 end Is_Descendant_At_Same_Level
;
1118 function Is_Primary_DT
(T
: Tag
) return Boolean is
1119 Signature
: constant Storage_Offset_Ptr
:=
1120 To_Storage_Offset_Ptr
(To_Address
(T
) - K_Signature
);
1121 Sig_Values
: constant Signature_Values
:=
1122 To_Signature_Values
(Signature
.all);
1124 return Sig_Values
(2) = Primary_DT
;
1131 function Length
(Str
: Cstring_Ptr
) return Natural is
1135 while Str
(Len
) /= ASCII
.Nul
loop
1146 function Offset_To_Top
1147 (This
: System
.Address
) return System
.Storage_Elements
.Storage_Offset
1149 Curr_DT
: constant Tag
:= To_Tag_Ptr
(This
).all;
1150 Offset_To_Top
: Storage_Offset_Ptr
;
1152 Offset_To_Top
:= To_Storage_Offset_Ptr
1153 (To_Address
(Curr_DT
) - K_Offset_To_Top
);
1155 if Offset_To_Top
.all = SSE
.Storage_Offset
'Last then
1156 Offset_To_Top
:= To_Storage_Offset_Ptr
(This
+ Tag_Size
);
1159 return Offset_To_Top
.all;
1166 function OSD
(T
: Tag
) return Object_Specific_Data_Ptr
is
1167 OSD_Ptr
: constant Addr_Ptr
:=
1168 To_Addr_Ptr
(To_Address
(T
) - K_Typeinfo
);
1170 pragma Assert
(Check_Signature
(T
, Must_Be_Secondary_DT
));
1171 return To_Object_Specific_Data_Ptr
(OSD_Ptr
.all);
1178 function Parent_Size
1179 (Obj
: System
.Address
;
1180 T
: Tag
) return SSE
.Storage_Count
1182 Parent_Slot
: constant Positive := 1;
1183 -- The tag of the parent is always in the first slot of the table of
1186 Size_Slot
: constant Positive := 1;
1187 -- The pointer to the _size primitive is always in the first slot of
1188 -- the dispatch table.
1191 -- The tag of the parent type through the dispatch table
1194 -- Access to the _size primitive of the parent
1197 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1198 Parent_Tag
:= TSD
(T
).Tags_Table
(Parent_Slot
);
1199 F
:= To_Acc_Size
(Predefined_DT
(Parent_Tag
).Prims_Ptr
(Size_Slot
));
1201 -- Here we compute the size of the _parent field of the object
1203 return SSE
.Storage_Count
(F
.all (Obj
));
1210 function Parent_Tag
(T
: Tag
) return Tag
is
1216 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1218 -- The Parent_Tag of a root-level tagged type is defined to be No_Tag.
1219 -- The first entry in the Ancestors_Tags array will be null for such
1220 -- a type, but it's better to be explicit about returning No_Tag in
1223 if TSD
(T
).Idepth
= 0 then
1226 return TSD
(T
).Tags_Table
(1);
1234 function Predefined_DT
(T
: Tag
) return Tag
is
1236 return To_Tag
(To_Address
(T
) - DT_Prologue_Size
);
1239 ----------------------------
1240 -- Register_Interface_Tag --
1241 ----------------------------
1243 procedure Register_Interface_Tag
1246 Position
: Positive)
1248 New_T_TSD
: Type_Specific_Data_Ptr
;
1249 Iface_Table
: Interface_Data_Ptr
;
1252 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Interface
));
1253 pragma Assert
(Check_Signature
(Interface_T
, Must_Be_Interface
));
1255 New_T_TSD
:= TSD
(T
);
1256 Iface_Table
:= To_Interface_Data_Ptr
(New_T_TSD
.Ifaces_Table_Ptr
);
1258 pragma Assert
(Position
<= Iface_Table
.Nb_Ifaces
);
1259 Iface_Table
.Table
(Position
).Iface_Tag
:= Interface_T
;
1260 end Register_Interface_Tag
;
1266 procedure Register_Tag
(T
: Tag
) is
1268 External_Tag_HTable
.Set
(T
);
1271 ----------------------
1272 -- Set_Access_Level --
1273 ----------------------
1275 procedure Set_Access_Level
(T
: Tag
; Value
: Natural) is
1277 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1278 TSD
(T
).Access_Level
:= Value
;
1279 end Set_Access_Level
;
1281 ---------------------
1282 -- Set_Entry_Index --
1283 ---------------------
1285 procedure Set_Entry_Index
1287 Position
: Positive;
1291 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1292 pragma Assert
(Position
<= Get_Num_Prim_Ops
(T
));
1293 SSD
(T
).SSD_Table
(Position
).Index
:= Value
;
1294 end Set_Entry_Index
;
1296 -----------------------
1297 -- Set_Expanded_Name --
1298 -----------------------
1300 procedure Set_Expanded_Name
(T
: Tag
; Value
: System
.Address
) is
1303 (Check_Signature
(T
, Must_Be_Primary_Or_Interface
));
1304 TSD
(T
).Expanded_Name
:= To_Cstring_Ptr
(Value
);
1305 end Set_Expanded_Name
;
1307 ----------------------
1308 -- Set_External_Tag --
1309 ----------------------
1311 procedure Set_External_Tag
(T
: Tag
; Value
: System
.Address
) is
1313 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Interface
));
1314 TSD
(T
).External_Tag
:= To_Cstring_Ptr
(Value
);
1315 end Set_External_Tag
;
1317 -------------------------
1318 -- Set_Interface_Table --
1319 -------------------------
1321 procedure Set_Interface_Table
(T
: Tag
; Value
: System
.Address
) is
1323 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Interface
));
1324 TSD
(T
).Ifaces_Table_Ptr
:= Value
;
1325 end Set_Interface_Table
;
1327 ----------------------
1328 -- Set_Num_Prim_Ops --
1329 ----------------------
1331 procedure Set_Num_Prim_Ops
(T
: Tag
; Value
: Natural) is
1333 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Secondary_DT
));
1335 if Is_Primary_DT
(T
) then
1336 TSD
(T
).Num_Prim_Ops
:= Value
;
1338 OSD
(T
).Num_Prim_Ops
:= Value
;
1340 end Set_Num_Prim_Ops
;
1342 ----------------------
1343 -- Set_Offset_Index --
1344 ----------------------
1346 procedure Set_Offset_Index
1348 Position
: Positive;
1352 pragma Assert
(Check_Signature
(T
, Must_Be_Secondary_DT
));
1353 pragma Assert
(Position
<= Get_Num_Prim_Ops
(T
));
1354 OSD
(T
).OSD_Table
(Position
) := Value
;
1355 end Set_Offset_Index
;
1357 -----------------------
1358 -- Set_Offset_To_Top --
1359 -----------------------
1361 procedure Set_Offset_To_Top
1362 (This
: System
.Address
;
1364 Is_Static
: Boolean;
1365 Offset_Value
: System
.Storage_Elements
.Storage_Offset
;
1366 Offset_Func
: System
.Address
)
1369 Sec_Base
: System
.Address
;
1371 Offset_To_Top
: Storage_Offset_Ptr
;
1372 Iface_Table
: Interface_Data_Ptr
;
1373 Obj_TSD
: Type_Specific_Data_Ptr
;
1375 if System
."=" (This
, System
.Null_Address
) then
1377 (Check_Signature
(Interface_T
, Must_Be_Primary_DT
));
1378 pragma Assert
(Offset_Value
= 0);
1381 To_Storage_Offset_Ptr
(To_Address
(Interface_T
) - K_Offset_To_Top
);
1382 Offset_To_Top
.all := Offset_Value
;
1386 -- "This" points to the primary DT and we must save Offset_Value in the
1387 -- Offset_To_Top field of the corresponding secondary dispatch table.
1389 Prim_DT
:= To_Tag_Ptr
(This
).all;
1392 (Check_Signature
(Prim_DT
, Must_Be_Primary_DT
));
1394 -- Save the offset to top field in the secondary dispatch table.
1396 if Offset_Value
/= 0 then
1397 Sec_Base
:= This
+ Offset_Value
;
1398 Sec_DT
:= To_Tag_Ptr
(Sec_Base
).all;
1400 To_Storage_Offset_Ptr
(To_Address
(Sec_DT
) - K_Offset_To_Top
);
1403 (Check_Signature
(Sec_DT
, Must_Be_Secondary_DT
));
1406 Offset_To_Top
.all := Offset_Value
;
1408 Offset_To_Top
.all := SSE
.Storage_Offset
'Last;
1412 -- Save Offset_Value in the table of interfaces of the primary DT. This
1413 -- data will be used by the subprogram "Displace" to give support to
1414 -- backward abstract interface type conversions.
1416 Obj_TSD
:= TSD
(Prim_DT
);
1417 Iface_Table
:= To_Interface_Data_Ptr
(Obj_TSD
.Ifaces_Table_Ptr
);
1419 -- Register the offset in the table of interfaces
1421 if Iface_Table
/= null then
1422 for Id
in 1 .. Iface_Table
.Nb_Ifaces
loop
1423 if Iface_Table
.Table
(Id
).Iface_Tag
= Interface_T
then
1424 Iface_Table
.Table
(Id
).Static_Offset_To_Top
:= Is_Static
;
1427 Iface_Table
.Table
(Id
).Offset_To_Top_Value
:= Offset_Value
;
1429 Iface_Table
.Table
(Id
).Offset_To_Top_Func
:= Offset_Func
;
1437 -- If we arrive here there is some error in the run-time data structure
1439 raise Program_Error
;
1440 end Set_Offset_To_Top
;
1446 procedure Set_OSD
(T
: Tag
; Value
: System
.Address
) is
1447 OSD_Ptr
: constant Addr_Ptr
:=
1448 To_Addr_Ptr
(To_Address
(T
) - K_Typeinfo
);
1450 pragma Assert
(Check_Signature
(T
, Must_Be_Secondary_DT
));
1451 OSD_Ptr
.all := Value
;
1454 ------------------------------------
1455 -- Set_Predefined_Prim_Op_Address --
1456 ------------------------------------
1458 procedure Set_Predefined_Prim_Op_Address
1460 Position
: Positive;
1461 Value
: System
.Address
)
1464 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Secondary_DT
));
1465 pragma Assert
(Position
>= 1 and then Position
<= Default_Prim_Op_Count
);
1466 Predefined_DT
(T
).Prims_Ptr
(Position
) := Value
;
1467 end Set_Predefined_Prim_Op_Address
;
1469 -------------------------
1470 -- Set_Prim_Op_Address --
1471 -------------------------
1473 procedure Set_Prim_Op_Address
1475 Position
: Positive;
1476 Value
: System
.Address
)
1479 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Secondary_DT
));
1480 pragma Assert
(Position
<= Get_Num_Prim_Ops
(T
));
1481 T
.Prims_Ptr
(Position
) := Value
;
1482 end Set_Prim_Op_Address
;
1484 ----------------------
1485 -- Set_Prim_Op_Kind --
1486 ----------------------
1488 procedure Set_Prim_Op_Kind
1490 Position
: Positive;
1491 Value
: Prim_Op_Kind
)
1494 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1495 pragma Assert
(Position
<= Get_Num_Prim_Ops
(T
));
1496 SSD
(T
).SSD_Table
(Position
).Kind
:= Value
;
1497 end Set_Prim_Op_Kind
;
1503 procedure Set_RC_Offset
(T
: Tag
; Value
: SSE
.Storage_Offset
) is
1505 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1506 TSD
(T
).RC_Offset
:= Value
;
1509 ---------------------------
1510 -- Set_Remotely_Callable --
1511 ---------------------------
1513 procedure Set_Remotely_Callable
(T
: Tag
; Value
: Boolean) is
1515 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1516 TSD
(T
).Remotely_Callable
:= Value
;
1517 end Set_Remotely_Callable
;
1523 procedure Set_Signature
(T
: Tag
; Value
: Signature_Kind
) is
1524 Signature
: constant System
.Address
:= To_Address
(T
) - K_Signature
;
1525 Sig_Ptr
: constant Signature_Values_Ptr
:=
1526 To_Signature_Values_Ptr
(Signature
);
1528 Sig_Ptr
.all (1) := Valid_Signature
;
1529 Sig_Ptr
.all (2) := Value
;
1536 procedure Set_SSD
(T
: Tag
; Value
: System
.Address
) is
1538 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1539 TSD
(T
).SSD_Ptr
:= Value
;
1542 ---------------------
1543 -- Set_Tagged_Kind --
1544 ---------------------
1546 procedure Set_Tagged_Kind
(T
: Tag
; Value
: Tagged_Kind
) is
1547 Tagged_Kind_Ptr
: constant System
.Address
:=
1548 To_Address
(T
) - K_Tagged_Kind
;
1550 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Secondary_DT
));
1551 To_Tagged_Kind_Ptr
(Tagged_Kind_Ptr
).all := Value
;
1552 end Set_Tagged_Kind
;
1558 procedure Set_TSD
(T
: Tag
; Value
: System
.Address
) is
1561 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Interface
));
1562 TSD_Ptr
:= To_Addr_Ptr
(To_Address
(T
) - K_Typeinfo
);
1563 TSD_Ptr
.all := Value
;
1570 function SSD
(T
: Tag
) return Select_Specific_Data_Ptr
is
1572 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1573 return To_Select_Specific_Data_Ptr
(TSD
(T
).SSD_Ptr
);
1580 function Typeinfo_Ptr
(T
: Tag
) return System
.Address
is
1581 TSD_Ptr
: constant Addr_Ptr
:=
1582 To_Addr_Ptr
(To_Address
(T
) - K_Typeinfo
);
1591 function TSD
(T
: Tag
) return Type_Specific_Data_Ptr
is
1592 TSD_Ptr
: constant Addr_Ptr
:=
1593 To_Addr_Ptr
(To_Address
(T
) - K_Typeinfo
);
1595 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Interface
));
1596 return To_Type_Specific_Data_Ptr
(TSD_Ptr
.all);
1599 ------------------------
1600 -- Wide_Expanded_Name --
1601 ------------------------
1603 WC_Encoding
: Character;
1604 pragma Import
(C
, WC_Encoding
, "__gl_wc_encoding");
1605 -- Encoding method for source, as exported by binder
1607 function Wide_Expanded_Name
(T
: Tag
) return Wide_String is
1609 return String_To_Wide_String
1610 (Expanded_Name
(T
), Get_WC_Encoding_Method
(WC_Encoding
));
1611 end Wide_Expanded_Name
;
1613 -----------------------------
1614 -- Wide_Wide_Expanded_Name --
1615 -----------------------------
1617 function Wide_Wide_Expanded_Name
(T
: Tag
) return Wide_Wide_String
is
1619 return String_To_Wide_Wide_String
1620 (Expanded_Name
(T
), Get_WC_Encoding_Method
(WC_Encoding
));
1621 end Wide_Wide_Expanded_Name
;