1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
9 -- Copyright (C) 1992-2005, 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
;
38 pragma Elaborate_All
(System
.HTable
);
40 package body Ada
.Tags
is
42 -- Structure of the GNAT Primary Dispatch Table
44 -- +----------------------+
46 -- +----------------------+
48 -- +----------------------+
50 -- +----------------------+
51 -- | Typeinfo_Ptr/TSD_Ptr ---> Type Specific Data
52 -- Tag ---> +----------------------+ +-------------------+
53 -- | table of | | inheritance depth |
54 -- : primitive ops : +-------------------+
55 -- | pointers | | access level |
56 -- +----------------------+ +-------------------+
58 -- +-------------------+
60 -- +-------------------+
61 -- | hash table link |
62 -- +-------------------+
63 -- | remotely callable |
64 -- +-------------------+
65 -- | rec ctrler offset |
66 -- +-------------------+
68 -- +-------------------+
70 -- +-------------------+
71 -- | Ifaces_Table_Ptr --> Interface Data
72 -- +-------------------+ +------------+
73 -- Select Specific Data <---- SSD_Ptr | | table |
74 -- +--------------------+ +-------------------+ : of :
75 -- | table of primitive | | table of | | interfaces |
76 -- : operation : : ancestor : +------------+
78 -- +--------------------+ +-------------------+
82 -- +--------------------+
84 -- Structure of the GNAT Secondary Dispatch Table
86 -- +-----------------------+
88 -- +-----------------------+
90 -- +-----------------------+
92 -- +-----------------------+
93 -- | OSD_Ptr |---> Object Specific Data
94 -- Tag ---> +-----------------------+ +---------------+
95 -- | table of | | num prim ops |
96 -- : primitive op : +---------------+
97 -- | thunk pointers | | table of |
98 -- +-----------------------+ + primitive |
102 ----------------------------------
103 -- GNAT Dispatch Table Prologue --
104 ----------------------------------
106 -- GNAT's Dispatch Table prologue contains several fields which are hidden
107 -- in order to preserve compatibility with C++. These fields are accessed
108 -- by address calculations performed in the following manner:
110 -- Field : Field_Type :=
111 -- (To_Address (Tag) - Sum_Of_Preceding_Field_Sizes).all;
113 -- The bracketed subtraction shifts the pointer (Tag) from the table of
114 -- primitive operations (or thunks) to the field in question. Since the
115 -- result of the subtraction is an address, dereferencing it will obtain
116 -- the actual value of the field.
118 -- Guidelines for addition of new hidden fields
120 -- Define a Field_Type and Field_Type_Ptr (access to Field_Type) in
121 -- A-Tags.ads for the newly introduced field.
123 -- Defined the size of the new field as a constant Field_Name_Size
125 -- Introduce an Unchecked_Conversion from System.Address to
126 -- Field_Type_Ptr in A-Tags.ads.
128 -- Define the specifications of Get_<Field_Name> and Set_<Field_Name>
131 -- Update the GNAT Dispatch Table structure in A-Tags.adb
133 -- Provide bodies to the Get_<Field_Name> and Set_<Field_Name> routines.
134 -- The profile of a Get_<Field_Name> routine should resemble:
136 -- function Get_<Field_Name> (T : Tag; ...) return Field_Type is
137 -- Field : constant System.Address :=
138 -- To_Address (T) - <Sum_Of_Previous_Field_Sizes>;
140 -- pragma Assert (Check_Signature (T, <Applicable_DT>));
141 -- <Additional_Assertions>
143 -- return To_Field_Type_Ptr (Field).all;
144 -- end Get_<Field_Name>;
146 -- The profile of a Set_<Field_Name> routine should resemble:
148 -- procedure Set_<Field_Name> (T : Tag; ..., Value : Field_Type) is
149 -- Field : constant System.Address :=
150 -- To_Address (T) - <Sum_Of_Previous_Field_Sizes>;
152 -- pragma Assert (Check_Signature (T, <Applicable_DT>));
153 -- <Additional_Assertions>
155 -- To_Field_Type_Ptr (Field).all := Value;
156 -- end Set_<Field_Name>;
158 -- NOTE: For each field in the prologue which precedes the newly added
159 -- one, find and update its respective Sum_Of_Previous_Field_Sizes by
160 -- subtractind Field_Name_Size from it. Falure to do so will clobber the
161 -- previous prologue field.
163 K_Typeinfo
: constant SSE
.Storage_Count
:= DT_Typeinfo_Ptr_Size
;
165 K_Offset_To_Top
: constant SSE
.Storage_Count
:=
166 K_Typeinfo
+ DT_Offset_To_Top_Size
;
168 K_Tagged_Kind
: constant SSE
.Storage_Count
:=
169 K_Offset_To_Top
+ DT_Tagged_Kind_Size
;
171 K_Signature
: constant SSE
.Storage_Count
:=
172 K_Tagged_Kind
+ DT_Signature_Size
;
174 subtype Cstring
is String (Positive);
175 type Cstring_Ptr
is access all Cstring
;
177 -- We suppress index checks because the declared size in the record below
178 -- is a dummy size of one (see below).
180 type Tag_Table
is array (Natural range <>) of Tag
;
181 pragma Suppress_Initialization
(Tag_Table
);
182 pragma Suppress
(Index_Check
, On
=> Tag_Table
);
184 -- Declarations for the table of interfaces
186 type Interface_Data_Element
is record
188 Offset
: System
.Storage_Elements
.Storage_Offset
;
191 type Interfaces_Array
is
192 array (Natural range <>) of Interface_Data_Element
;
194 type Interface_Data
(Nb_Ifaces
: Positive) is record
195 Table
: Interfaces_Array
(1 .. Nb_Ifaces
);
198 -- Object specific data types
200 type Object_Specific_Data_Array
is array (Positive range <>) of Positive;
202 type Object_Specific_Data
(Nb_Prim
: Positive) is record
203 Num_Prim_Ops
: Natural;
204 -- Number of primitive operations of the dispatch table. This field is
205 -- used by the run-time check routines that are activated when the
206 -- run-time is compiled with assertions enabled.
208 OSD_Table
: Object_Specific_Data_Array
(1 .. Nb_Prim
);
209 -- Table used in secondary DT to reference their counterpart in the
210 -- select specific data (in the TSD of the primary DT). This construct
211 -- is used in the handling of dispatching triggers in select statements.
212 -- Nb_Prim is the number of non-predefined primitive operations.
215 -- Select specific data types
217 type Select_Specific_Data_Element
is record
222 type Select_Specific_Data_Array
is
223 array (Positive range <>) of Select_Specific_Data_Element
;
225 type Select_Specific_Data
(Nb_Prim
: Positive) is record
226 SSD_Table
: Select_Specific_Data_Array
(1 .. Nb_Prim
);
227 -- NOTE: Nb_Prim is the number of non-predefined primitive operations
230 -- Type specific data types
232 type Type_Specific_Data
is record
234 -- Inheritance Depth Level: Used to implement the membership test
235 -- associated with single inheritance of tagged types in constant-time.
236 -- In addition it also indicates the size of the first table stored in
237 -- the Tags_Table component (see comment below).
239 Access_Level
: Natural;
240 -- Accessibility level required to give support to Ada 2005 nested type
241 -- extensions. This feature allows safe nested type extensions by
242 -- shifting the accessibility checks to certain operations, rather than
243 -- being enforced at the type declaration. In particular, by performing
244 -- run-time accessibility checks on class-wide allocators, class-wide
245 -- function return, and class-wide stream I/O, the danger of objects
246 -- outliving their type declaration can be eliminated (Ada 2005: AI-344)
248 Expanded_Name
: Cstring_Ptr
;
249 External_Tag
: Cstring_Ptr
;
251 -- Components used to give support to the Ada.Tags subprograms described
254 Remotely_Callable
: Boolean;
255 -- Used to check ARM E.4 (18)
257 RC_Offset
: SSE
.Storage_Offset
;
258 -- Controller Offset: Used to give support to tagged controlled objects
259 -- (see Get_Deep_Controller at s-finimp)
261 Ifaces_Table_Ptr
: System
.Address
;
262 -- Pointer to the table of interface tags. It is used to implement the
263 -- membership test associated with interfaces and also for backward
264 -- abstract interface type conversions (Ada 2005:AI-251)
266 Num_Prim_Ops
: Natural;
267 -- Number of primitive operations of the dispatch table. This field is
268 -- used for additional run-time checks when the run-time is compiled
269 -- with assertions enabled.
271 SSD_Ptr
: System
.Address
;
272 -- Pointer to a table of records used in dispatching selects. This
273 -- field has a meaningful value for all tagged types that implement
274 -- a limited, protected, synchronized or task interfaces and have
275 -- non-predefined primitive operations.
277 Tags_Table
: Tag_Table
(0 .. 1);
278 -- The size of the Tags_Table array actually depends on the tagged type
279 -- to which it applies. The compiler ensures that has enough space to
280 -- store all the entries of the two tables phisically stored there: the
281 -- "table of ancestor tags" and the "table of interface tags". For this
282 -- purpose we are using the same mechanism as for the Prims_Ptr array in
283 -- the Dispatch_Table record. See comments below on Prims_Ptr for
287 type Dispatch_Table
is record
289 -- According to the C++ ABI the components Offset_To_Top and
290 -- Typeinfo_Ptr are stored just "before" the dispatch table (that is,
291 -- the Prims_Ptr table), and they are referenced with negative offsets
292 -- referring to the base of the dispatch table. The _Tag (or the
293 -- VTable_Ptr in C++ terminology) must point to the base of the virtual
294 -- table, just after these components, to point to the Prims_Ptr table.
295 -- For this purpose the expander generates a Prims_Ptr table that has
296 -- enough space for these additional components, and generates code that
297 -- displaces the _Tag to point after these components.
299 -- Signature : Signature_Kind;
300 -- Tagged_Kind : Tagged_Kind;
301 -- Offset_To_Top : Natural;
302 -- Typeinfo_Ptr : System.Address;
304 Prims_Ptr
: Address_Array
(1 .. 1);
305 -- The size of the Prims_Ptr array actually depends on the tagged type
306 -- to which it applies. For each tagged type, the expander computes the
307 -- actual array size, allocates the Dispatch_Table record accordingly,
308 -- and generates code that displaces the base of the record after the
309 -- Typeinfo_Ptr component. For this reason the first two components have
310 -- been commented in the previous declaration. The access to these
311 -- components is done by means of local functions.
313 -- To avoid the use of discriminants to define the actual size of the
314 -- dispatch table, we used to declare the tag as a pointer to a record
315 -- that contains an arbitrary array of addresses, using Positive as its
316 -- index. This ensures that there are never range checks when accessing
317 -- the dispatch table, but it prevents GDB from displaying tagged types
318 -- properly. A better approach is to declare this record type as holding
319 -- small number of addresses, and to explicitly suppress checks on it.
321 -- Note that in both cases, this type is never allocated, and serves
322 -- only to declare the corresponding access type.
325 -- Run-time check types and subprograms: These subprograms are used only
326 -- when the run-time is compiled with assertions enabled.
328 type Signature_Type
is
330 Must_Be_Secondary_DT
,
331 Must_Be_Primary_Or_Secondary_DT
,
333 Must_Be_Primary_Or_Interface
);
334 -- Type of signature accepted by primitives in this package that are called
335 -- during the elaboration of tagged types. This type is used by the routine
336 -- Check_Signature that is called only when the run-time is compiled with
337 -- assertions enabled.
339 ---------------------------------------------
340 -- Unchecked Conversions for String Fields --
341 ---------------------------------------------
343 function To_Address
is
344 new Unchecked_Conversion
(Cstring_Ptr
, System
.Address
);
346 function To_Cstring_Ptr
is
347 new Unchecked_Conversion
(System
.Address
, Cstring_Ptr
);
349 ------------------------------------------------
350 -- Unchecked Conversions for other components --
351 ------------------------------------------------
354 is access function (A
: System
.Address
) return Long_Long_Integer;
356 function To_Acc_Size
is new Unchecked_Conversion
(System
.Address
, Acc_Size
);
357 -- The profile of the implicitly defined _size primitive
359 type Storage_Offset_Ptr
is access System
.Storage_Elements
.Storage_Offset
;
361 function To_Storage_Offset_Ptr
is
362 new Unchecked_Conversion
(System
.Address
, Storage_Offset_Ptr
);
364 -----------------------
365 -- Local Subprograms --
366 -----------------------
370 Index
: Natural) return Boolean;
371 -- Check that Index references a valid entry of the dispatch table of T
373 function Check_Signature
(T
: Tag
; Kind
: Signature_Type
) return Boolean;
374 -- Check that the signature of T is valid and corresponds with the subset
375 -- specified by the signature Kind.
380 Entry_Count
: Natural) return Boolean;
381 -- Verify that Old_T and New_T have at least Entry_Count entries
383 function Get_Num_Prim_Ops
(T
: Tag
) return Natural;
384 -- Retrieve the number of primitive operations in the dispatch table of T
386 function Is_Primary_DT
(T
: Tag
) return Boolean;
387 pragma Inline_Always
(Is_Primary_DT
);
388 -- Given a tag returns True if it has the signature of a primary dispatch
389 -- table. This is Inline_Always since it is called from other Inline_
390 -- Always subprograms where we want no out of line code to be generated.
392 function Length
(Str
: Cstring_Ptr
) return Natural;
393 -- Length of string represented by the given pointer (treating the string
394 -- as a C-style string, which is Nul terminated).
396 function Typeinfo_Ptr
(T
: Tag
) return System
.Address
;
397 -- Returns the current value of the typeinfo_ptr component available in
398 -- the prologue of the dispatch table.
400 pragma Unreferenced
(Typeinfo_Ptr
);
401 -- These functions will be used for full compatibility with the C++ ABI
403 -------------------------
404 -- External_Tag_HTable --
405 -------------------------
407 type HTable_Headers
is range 1 .. 64;
409 -- The following internal package defines the routines used for the
410 -- instantiation of a new System.HTable.Static_HTable (see below). See
411 -- spec in g-htable.ads for details of usage.
413 package HTable_Subprograms
is
414 procedure Set_HT_Link
(T
: Tag
; Next
: Tag
);
415 function Get_HT_Link
(T
: Tag
) return Tag
;
416 function Hash
(F
: System
.Address
) return HTable_Headers
;
417 function Equal
(A
, B
: System
.Address
) return Boolean;
418 end HTable_Subprograms
;
420 package External_Tag_HTable
is new System
.HTable
.Static_HTable
(
421 Header_Num
=> HTable_Headers
,
422 Element
=> Dispatch_Table
,
425 Set_Next
=> HTable_Subprograms
.Set_HT_Link
,
426 Next
=> HTable_Subprograms
.Get_HT_Link
,
427 Key
=> System
.Address
,
428 Get_Key
=> Get_External_Tag
,
429 Hash
=> HTable_Subprograms
.Hash
,
430 Equal
=> HTable_Subprograms
.Equal
);
432 ------------------------
433 -- HTable_Subprograms --
434 ------------------------
436 -- Bodies of routines for hash table instantiation
438 package body HTable_Subprograms
is
444 function Equal
(A
, B
: System
.Address
) return Boolean is
445 Str1
: constant Cstring_Ptr
:= To_Cstring_Ptr
(A
);
446 Str2
: constant Cstring_Ptr
:= To_Cstring_Ptr
(B
);
450 if Str1
(J
) /= Str2
(J
) then
452 elsif Str1
(J
) = ASCII
.NUL
then
464 function Get_HT_Link
(T
: Tag
) return Tag
is
466 return TSD
(T
).HT_Link
;
473 function Hash
(F
: System
.Address
) return HTable_Headers
is
474 function H
is new System
.HTable
.Hash
(HTable_Headers
);
475 Str
: constant Cstring_Ptr
:= To_Cstring_Ptr
(F
);
476 Res
: constant HTable_Headers
:= H
(Str
(1 .. Length
(Str
)));
485 procedure Set_HT_Link
(T
: Tag
; Next
: Tag
) is
487 TSD
(T
).HT_Link
:= Next
;
490 end HTable_Subprograms
;
498 Index
: Natural) return Boolean
500 Max_Entries
: constant Natural := Get_Num_Prim_Ops
(T
);
503 return Index
/= 0 and then Index
<= Max_Entries
;
506 ---------------------
507 -- Check_Signature --
508 ---------------------
510 function Check_Signature
(T
: Tag
; Kind
: Signature_Type
) return Boolean is
511 Signature
: constant Storage_Offset_Ptr
:=
512 To_Storage_Offset_Ptr
(To_Address
(T
) - K_Signature
);
514 Sig_Values
: constant Signature_Values
:=
515 To_Signature_Values
(Signature
.all);
517 Signature_Id
: Signature_Kind
;
520 if Sig_Values
(1) /= Valid_Signature
then
521 Signature_Id
:= Unknown
;
523 elsif Sig_Values
(2) in Primary_DT
.. Abstract_Interface
then
524 Signature_Id
:= Sig_Values
(2);
527 Signature_Id
:= Unknown
;
532 if Kind
= Must_Be_Secondary_DT
533 or else Kind
= Must_Be_Interface
539 if Kind
= Must_Be_Primary_DT
540 or else Kind
= Must_Be_Interface
545 when Abstract_Interface
=>
546 if Kind
= Must_Be_Primary_DT
547 or else Kind
= Must_Be_Secondary_DT
548 or else Kind
= Must_Be_Primary_Or_Secondary_DT
568 Entry_Count
: Natural) return Boolean
570 Max_Entries_Old
: constant Natural := Get_Num_Prim_Ops
(Old_T
);
571 Max_Entries_New
: constant Natural := Get_Num_Prim_Ops
(New_T
);
574 return Entry_Count
<= Max_Entries_Old
575 and then Entry_Count
<= Max_Entries_New
;
582 -- Canonical implementation of Classwide Membership corresponding to:
586 -- Each dispatch table contains a reference to a table of ancestors (stored
587 -- in the first part of the Tags_Table) and a count of the level of
588 -- inheritance "Idepth".
590 -- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
591 -- contained in the dispatch table referenced by Obj'Tag . Knowing the
592 -- level of inheritance of both types, this can be computed in constant
593 -- time by the formula:
595 -- Obj'tag.TSD.Ancestor_Tags (Obj'tag.TSD.Idepth - Typ'tag.TSD.Idepth)
598 function CW_Membership
(Obj_Tag
: Tag
; Typ_Tag
: Tag
) return Boolean is
601 pragma Assert
(Check_Signature
(Obj_Tag
, Must_Be_Primary_DT
));
602 pragma Assert
(Check_Signature
(Typ_Tag
, Must_Be_Primary_DT
));
603 Pos
:= TSD
(Obj_Tag
).Idepth
- TSD
(Typ_Tag
).Idepth
;
604 return Pos
>= 0 and then TSD
(Obj_Tag
).Tags_Table
(Pos
) = Typ_Tag
;
612 (This
: System
.Address
;
613 T
: Tag
) return System
.Address
615 Curr_DT
: constant Tag
:= To_Tag_Ptr
(This
).all;
616 Iface_Table
: Interface_Data_Ptr
;
617 Obj_Base
: System
.Address
;
619 Obj_TSD
: Type_Specific_Data_Ptr
;
623 (Check_Signature
(Curr_DT
, Must_Be_Primary_Or_Secondary_DT
));
625 (Check_Signature
(T
, Must_Be_Interface
));
627 Obj_Base
:= This
- Offset_To_Top
(Curr_DT
);
628 Obj_DT
:= To_Tag_Ptr
(Obj_Base
).all;
631 (Check_Signature
(Obj_DT
, Must_Be_Primary_DT
));
633 Obj_TSD
:= TSD
(Obj_DT
);
634 Iface_Table
:= To_Interface_Data_Ptr
(Obj_TSD
.Ifaces_Table_Ptr
);
636 if Iface_Table
/= null then
637 for Id
in 1 .. Iface_Table
.Nb_Ifaces
loop
638 if Iface_Table
.Table
(Id
).Iface_Tag
= T
then
639 Obj_Base
:= Obj_Base
+ Iface_Table
.Table
(Id
).Offset
;
640 Obj_DT
:= To_Tag_Ptr
(Obj_Base
).all;
643 (Check_Signature
(Obj_DT
, Must_Be_Secondary_DT
));
650 -- If the object does not implement the interface we must raise CE
652 raise Constraint_Error
;
659 -- Canonical implementation of Classwide Membership corresponding to:
661 -- Obj in Iface'Class
663 -- Each dispatch table contains a table with the tags of all the
664 -- implemented interfaces.
666 -- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
667 -- that are contained in the dispatch table referenced by Obj'Tag.
669 function IW_Membership
(This
: System
.Address
; T
: Tag
) return Boolean is
670 Curr_DT
: constant Tag
:= To_Tag_Ptr
(This
).all;
671 Iface_Table
: Interface_Data_Ptr
;
673 Obj_Base
: System
.Address
;
675 Obj_TSD
: Type_Specific_Data_Ptr
;
679 (Check_Signature
(Curr_DT
, Must_Be_Primary_Or_Secondary_DT
));
681 (Check_Signature
(T
, Must_Be_Primary_Or_Interface
));
683 Obj_Base
:= This
- Offset_To_Top
(Curr_DT
);
684 Obj_DT
:= To_Tag_Ptr
(Obj_Base
).all;
687 (Check_Signature
(Obj_DT
, Must_Be_Primary_DT
));
689 Obj_TSD
:= TSD
(Obj_DT
);
690 Last_Id
:= Obj_TSD
.Idepth
;
692 -- Look for the tag in the table of interfaces
694 Iface_Table
:= To_Interface_Data_Ptr
(Obj_TSD
.Ifaces_Table_Ptr
);
696 if Iface_Table
/= null then
697 for Id
in 1 .. Iface_Table
.Nb_Ifaces
loop
698 if Iface_Table
.Table
(Id
).Iface_Tag
= T
then
704 -- Look for the tag in the ancestor tags table. This is required for:
705 -- Iface_CW in Typ'Class
707 for Id
in 0 .. Last_Id
loop
708 if Obj_TSD
.Tags_Table
(Id
) = T
then
720 function Descendant_Tag
(External
: String; Ancestor
: Tag
) return Tag
is
724 pragma Assert
(Check_Signature
(Ancestor
, Must_Be_Primary_DT
));
725 Int_Tag
:= Internal_Tag
(External
);
726 pragma Assert
(Check_Signature
(Int_Tag
, Must_Be_Primary_DT
));
728 if not Is_Descendant_At_Same_Level
(Int_Tag
, Ancestor
) then
739 function Expanded_Name
(T
: Tag
) return String is
740 Result
: Cstring_Ptr
;
747 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Interface
));
748 Result
:= TSD
(T
).Expanded_Name
;
749 return Result
(1 .. Length
(Result
));
756 function External_Tag
(T
: Tag
) return String is
757 Result
: Cstring_Ptr
;
764 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Interface
));
765 Result
:= TSD
(T
).External_Tag
;
767 return Result
(1 .. Length
(Result
));
770 ----------------------
771 -- Get_Access_Level --
772 ----------------------
774 function Get_Access_Level
(T
: Tag
) return Natural is
776 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
777 return TSD
(T
).Access_Level
;
778 end Get_Access_Level
;
780 ---------------------
781 -- Get_Entry_Index --
782 ---------------------
784 function Get_Entry_Index
(T
: Tag
; Position
: Positive) return Positive is
785 Index
: constant Integer := Position
- Default_Prim_Op_Count
;
787 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
788 pragma Assert
(Check_Index
(T
, Position
));
789 pragma Assert
(Index
> 0);
790 return SSD
(T
).SSD_Table
(Index
).Index
;
793 ----------------------
794 -- Get_External_Tag --
795 ----------------------
797 function Get_External_Tag
(T
: Tag
) return System
.Address
is
799 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
800 return To_Address
(TSD
(T
).External_Tag
);
801 end Get_External_Tag
;
803 ----------------------
804 -- Get_Num_Prim_Ops --
805 ----------------------
807 function Get_Num_Prim_Ops
(T
: Tag
) return Natural is
809 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Secondary_DT
));
811 if Is_Primary_DT
(T
) then
812 return TSD
(T
).Num_Prim_Ops
;
814 return OSD
(T
).Num_Prim_Ops
;
816 end Get_Num_Prim_Ops
;
818 -------------------------
819 -- Get_Prim_Op_Address --
820 -------------------------
822 function Get_Prim_Op_Address
824 Position
: Positive) return System
.Address
827 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Secondary_DT
));
828 pragma Assert
(Check_Index
(T
, Position
));
829 return T
.Prims_Ptr
(Position
);
830 end Get_Prim_Op_Address
;
832 ----------------------
833 -- Get_Prim_Op_Kind --
834 ----------------------
836 function Get_Prim_Op_Kind
838 Position
: Positive) return Prim_Op_Kind
840 Index
: constant Integer := Position
- Default_Prim_Op_Count
;
842 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
843 pragma Assert
(Check_Index
(T
, Position
));
844 pragma Assert
(Index
> 0);
845 return SSD
(T
).SSD_Table
(Index
).Kind
;
846 end Get_Prim_Op_Kind
;
848 ----------------------
849 -- Get_Offset_Index --
850 ----------------------
852 function Get_Offset_Index
854 Position
: Positive) return Positive
856 Index
: constant Integer := Position
- Default_Prim_Op_Count
;
858 pragma Assert
(Check_Signature
(T
, Must_Be_Secondary_DT
));
859 pragma Assert
(Check_Index
(T
, Position
));
860 pragma Assert
(Index
> 0);
861 return OSD
(T
).OSD_Table
(Index
);
862 end Get_Offset_Index
;
868 function Get_RC_Offset
(T
: Tag
) return SSE
.Storage_Offset
is
870 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
871 return TSD
(T
).RC_Offset
;
874 ---------------------------
875 -- Get_Remotely_Callable --
876 ---------------------------
878 function Get_Remotely_Callable
(T
: Tag
) return Boolean is
880 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
881 return TSD
(T
).Remotely_Callable
;
882 end Get_Remotely_Callable
;
884 ---------------------
885 -- Get_Tagged_Kind --
886 ---------------------
888 function Get_Tagged_Kind
(T
: Tag
) return Tagged_Kind
is
889 Tagged_Kind_Ptr
: constant System
.Address
:=
890 To_Address
(T
) - K_Tagged_Kind
;
892 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Secondary_DT
));
893 return To_Tagged_Kind_Ptr
(Tagged_Kind_Ptr
).all;
900 procedure Inherit_DT
(Old_T
: Tag
; New_T
: Tag
; Entry_Count
: Natural) is
902 pragma Assert
(Check_Signature
(Old_T
, Must_Be_Primary_Or_Secondary_DT
));
903 pragma Assert
(Check_Signature
(New_T
, Must_Be_Primary_Or_Secondary_DT
));
904 pragma Assert
(Check_Size
(Old_T
, New_T
, Entry_Count
));
906 if Old_T
/= null then
907 New_T
.Prims_Ptr
(1 .. Entry_Count
) :=
908 Old_T
.Prims_Ptr
(1 .. Entry_Count
);
916 procedure Inherit_TSD
(Old_Tag
: Tag
; New_Tag
: Tag
) is
917 New_TSD_Ptr
: Type_Specific_Data_Ptr
;
918 New_Iface_Table_Ptr
: Interface_Data_Ptr
;
919 Old_TSD_Ptr
: Type_Specific_Data_Ptr
;
920 Old_Iface_Table_Ptr
: Interface_Data_Ptr
;
923 pragma Assert
(Check_Signature
(New_Tag
, Must_Be_Primary_Or_Interface
));
924 New_TSD_Ptr
:= TSD
(New_Tag
);
926 if Old_Tag
/= null then
928 (Check_Signature
(Old_Tag
, Must_Be_Primary_Or_Interface
));
929 Old_TSD_Ptr
:= TSD
(Old_Tag
);
930 New_TSD_Ptr
.Idepth
:= Old_TSD_Ptr
.Idepth
+ 1;
932 -- Copy the "table of ancestor tags" plus the "table of interfaces"
935 New_TSD_Ptr
.Tags_Table
(1 .. New_TSD_Ptr
.Idepth
) :=
936 Old_TSD_Ptr
.Tags_Table
(0 .. Old_TSD_Ptr
.Idepth
);
938 -- Copy the table of interfaces of the parent
940 if not System
."=" (Old_TSD_Ptr
.Ifaces_Table_Ptr
,
943 Old_Iface_Table_Ptr
:=
944 To_Interface_Data_Ptr
(Old_TSD_Ptr
.Ifaces_Table_Ptr
);
945 New_Iface_Table_Ptr
:=
946 To_Interface_Data_Ptr
(New_TSD_Ptr
.Ifaces_Table_Ptr
);
948 New_Iface_Table_Ptr
.Table
(1 .. Old_Iface_Table_Ptr
.Nb_Ifaces
) :=
949 Old_Iface_Table_Ptr
.Table
(1 .. Old_Iface_Table_Ptr
.Nb_Ifaces
);
953 New_TSD_Ptr
.Idepth
:= 0;
956 New_TSD_Ptr
.Tags_Table
(0) := New_Tag
;
963 function Internal_Tag
(External
: String) return Tag
is
964 Ext_Copy
: aliased String (External
'First .. External
'Last + 1);
968 -- Make a copy of the string representing the external tag with
969 -- a null at the end.
971 Ext_Copy
(External
'Range) := External
;
972 Ext_Copy
(Ext_Copy
'Last) := ASCII
.NUL
;
973 Res
:= External_Tag_HTable
.Get
(Ext_Copy
'Address);
977 Msg1
: constant String := "unknown tagged type: ";
978 Msg2
: String (1 .. Msg1
'Length + External
'Length);
981 Msg2
(1 .. Msg1
'Length) := Msg1
;
982 Msg2
(Msg1
'Length + 1 .. Msg1
'Length + External
'Length) :=
984 Ada
.Exceptions
.Raise_Exception
(Tag_Error
'Identity, Msg2
);
991 ---------------------------------
992 -- Is_Descendant_At_Same_Level --
993 ---------------------------------
995 function Is_Descendant_At_Same_Level
997 Ancestor
: Tag
) return Boolean
1000 return CW_Membership
(Descendant
, Ancestor
)
1001 and then TSD
(Descendant
).Access_Level
= TSD
(Ancestor
).Access_Level
;
1002 end Is_Descendant_At_Same_Level
;
1008 function Is_Primary_DT
(T
: Tag
) return Boolean is
1009 Signature
: constant Storage_Offset_Ptr
:=
1010 To_Storage_Offset_Ptr
(To_Address
(T
) - K_Signature
);
1011 Sig_Values
: constant Signature_Values
:=
1012 To_Signature_Values
(Signature
.all);
1014 return Sig_Values
(2) = Primary_DT
;
1021 function Length
(Str
: Cstring_Ptr
) return Natural is
1025 while Str
(Len
) /= ASCII
.Nul
loop
1036 function Offset_To_Top
1037 (T
: Tag
) return System
.Storage_Elements
.Storage_Offset
1039 Offset_To_Top
: constant Storage_Offset_Ptr
:=
1040 To_Storage_Offset_Ptr
1041 (To_Address
(T
) - K_Offset_To_Top
);
1043 return Offset_To_Top
.all;
1050 function OSD
(T
: Tag
) return Object_Specific_Data_Ptr
is
1051 OSD_Ptr
: constant Addr_Ptr
:=
1052 To_Addr_Ptr
(To_Address
(T
) - K_Typeinfo
);
1054 pragma Assert
(Check_Signature
(T
, Must_Be_Secondary_DT
));
1055 return To_Object_Specific_Data_Ptr
(OSD_Ptr
.all);
1062 function Parent_Size
1063 (Obj
: System
.Address
;
1064 T
: Tag
) return SSE
.Storage_Count
1067 -- The tag of the parent type through the dispatch table
1070 -- Access to the _size primitive of the parent. We assume that it is
1071 -- always in the first slot of the dispatch table.
1074 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1075 Parent_Tag
:= TSD
(T
).Tags_Table
(1);
1076 F
:= To_Acc_Size
(Parent_Tag
.Prims_Ptr
(1));
1078 -- Here we compute the size of the _parent field of the object
1080 return SSE
.Storage_Count
(F
.all (Obj
));
1087 function Parent_Tag
(T
: Tag
) return Tag
is
1093 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1095 -- The Parent_Tag of a root-level tagged type is defined to be No_Tag.
1096 -- The first entry in the Ancestors_Tags array will be null for such
1097 -- a type, but it's better to be explicit about returning No_Tag in
1100 if TSD
(T
).Idepth
= 0 then
1103 return TSD
(T
).Tags_Table
(1);
1107 ----------------------------
1108 -- Register_Interface_Tag --
1109 ----------------------------
1111 procedure Register_Interface_Tag
1114 Position
: Positive)
1116 New_T_TSD
: Type_Specific_Data_Ptr
;
1117 Iface_Table
: Interface_Data_Ptr
;
1120 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1121 pragma Assert
(Check_Signature
(Interface_T
, Must_Be_Interface
));
1123 New_T_TSD
:= TSD
(T
);
1124 Iface_Table
:= To_Interface_Data_Ptr
(New_T_TSD
.Ifaces_Table_Ptr
);
1126 pragma Assert
(Position
<= Iface_Table
.Nb_Ifaces
);
1128 Iface_Table
.Table
(Position
).Iface_Tag
:= Interface_T
;
1129 end Register_Interface_Tag
;
1135 procedure Register_Tag
(T
: Tag
) is
1137 External_Tag_HTable
.Set
(T
);
1140 ----------------------
1141 -- Set_Access_Level --
1142 ----------------------
1144 procedure Set_Access_Level
(T
: Tag
; Value
: Natural) is
1146 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1147 TSD
(T
).Access_Level
:= Value
;
1148 end Set_Access_Level
;
1150 ---------------------
1151 -- Set_Entry_Index --
1152 ---------------------
1154 procedure Set_Entry_Index
1156 Position
: Positive;
1159 Index
: constant Integer := Position
- Default_Prim_Op_Count
;
1161 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1162 pragma Assert
(Check_Index
(T
, Position
));
1163 pragma Assert
(Index
> 0);
1164 SSD
(T
).SSD_Table
(Index
).Index
:= Value
;
1165 end Set_Entry_Index
;
1167 -----------------------
1168 -- Set_Expanded_Name --
1169 -----------------------
1171 procedure Set_Expanded_Name
(T
: Tag
; Value
: System
.Address
) is
1174 (Check_Signature
(T
, Must_Be_Primary_Or_Interface
));
1175 TSD
(T
).Expanded_Name
:= To_Cstring_Ptr
(Value
);
1176 end Set_Expanded_Name
;
1178 ----------------------
1179 -- Set_External_Tag --
1180 ----------------------
1182 procedure Set_External_Tag
(T
: Tag
; Value
: System
.Address
) is
1184 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Interface
));
1185 TSD
(T
).External_Tag
:= To_Cstring_Ptr
(Value
);
1186 end Set_External_Tag
;
1188 -------------------------
1189 -- Set_Interface_Table --
1190 -------------------------
1192 procedure Set_Interface_Table
(T
: Tag
; Value
: System
.Address
) is
1194 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1195 TSD
(T
).Ifaces_Table_Ptr
:= Value
;
1196 end Set_Interface_Table
;
1198 ----------------------
1199 -- Set_Num_Prim_Ops --
1200 ----------------------
1202 procedure Set_Num_Prim_Ops
(T
: Tag
; Value
: Natural) is
1204 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Secondary_DT
));
1206 if Is_Primary_DT
(T
) then
1207 TSD
(T
).Num_Prim_Ops
:= Value
;
1209 OSD
(T
).Num_Prim_Ops
:= Value
;
1211 end Set_Num_Prim_Ops
;
1213 ----------------------
1214 -- Set_Offset_Index --
1215 ----------------------
1217 procedure Set_Offset_Index
1219 Position
: Positive;
1222 Index
: constant Integer := Position
- Default_Prim_Op_Count
;
1224 pragma Assert
(Check_Signature
(T
, Must_Be_Secondary_DT
));
1225 pragma Assert
(Check_Index
(T
, Position
));
1226 pragma Assert
(Index
> 0);
1227 OSD
(T
).OSD_Table
(Index
) := Value
;
1228 end Set_Offset_Index
;
1230 -----------------------
1231 -- Set_Offset_To_Top --
1232 -----------------------
1234 procedure Set_Offset_To_Top
1235 (This
: System
.Address
;
1237 Offset_Value
: System
.Storage_Elements
.Storage_Offset
)
1240 Sec_Base
: System
.Address
;
1242 Offset_To_Top
: Storage_Offset_Ptr
;
1243 Iface_Table
: Interface_Data_Ptr
;
1244 Obj_TSD
: Type_Specific_Data_Ptr
;
1246 if System
."=" (This
, System
.Null_Address
) then
1248 (Check_Signature
(Interface_T
, Must_Be_Primary_DT
));
1249 pragma Assert
(Offset_Value
= 0);
1252 To_Storage_Offset_Ptr
(To_Address
(Interface_T
) - K_Offset_To_Top
);
1253 Offset_To_Top
.all := Offset_Value
;
1257 -- "This" points to the primary DT and we must save Offset_Value in the
1258 -- Offset_To_Top field of the corresponding secondary dispatch table.
1260 Prim_DT
:= To_Tag_Ptr
(This
).all;
1263 (Check_Signature
(Prim_DT
, Must_Be_Primary_DT
));
1265 Sec_Base
:= This
+ Offset_Value
;
1266 Sec_DT
:= To_Tag_Ptr
(Sec_Base
).all;
1268 To_Storage_Offset_Ptr
(To_Address
(Sec_DT
) - K_Offset_To_Top
);
1271 (Check_Signature
(Sec_DT
, Must_Be_Primary_Or_Secondary_DT
));
1273 Offset_To_Top
.all := Offset_Value
;
1275 -- Save Offset_Value in the table of interfaces of the primary DT. This
1276 -- data will be used by the subprogram "Displace" to give support to
1277 -- backward abstract interface type conversions.
1279 Obj_TSD
:= TSD
(Prim_DT
);
1280 Iface_Table
:= To_Interface_Data_Ptr
(Obj_TSD
.Ifaces_Table_Ptr
);
1282 -- Register the offset in the table of interfaces
1284 if Iface_Table
/= null then
1285 for Id
in 1 .. Iface_Table
.Nb_Ifaces
loop
1286 if Iface_Table
.Table
(Id
).Iface_Tag
= Interface_T
then
1287 Iface_Table
.Table
(Id
).Offset
:= Offset_Value
;
1293 -- If we arrive here there is some error in the run-time data structure
1295 raise Program_Error
;
1296 end Set_Offset_To_Top
;
1302 procedure Set_OSD
(T
: Tag
; Value
: System
.Address
) is
1303 OSD_Ptr
: constant Addr_Ptr
:=
1304 To_Addr_Ptr
(To_Address
(T
) - K_Typeinfo
);
1306 pragma Assert
(Check_Signature
(T
, Must_Be_Secondary_DT
));
1307 OSD_Ptr
.all := Value
;
1310 -------------------------
1311 -- Set_Prim_Op_Address --
1312 -------------------------
1314 procedure Set_Prim_Op_Address
1316 Position
: Positive;
1317 Value
: System
.Address
)
1320 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Secondary_DT
));
1321 pragma Assert
(Check_Index
(T
, Position
));
1322 T
.Prims_Ptr
(Position
) := Value
;
1323 end Set_Prim_Op_Address
;
1325 ----------------------
1326 -- Set_Prim_Op_Kind --
1327 ----------------------
1329 procedure Set_Prim_Op_Kind
1331 Position
: Positive;
1332 Value
: Prim_Op_Kind
)
1334 Index
: constant Integer := Position
- Default_Prim_Op_Count
;
1336 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1337 pragma Assert
(Check_Index
(T
, Position
));
1338 pragma Assert
(Index
> 0);
1339 SSD
(T
).SSD_Table
(Index
).Kind
:= Value
;
1340 end Set_Prim_Op_Kind
;
1346 procedure Set_RC_Offset
(T
: Tag
; Value
: SSE
.Storage_Offset
) is
1348 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1349 TSD
(T
).RC_Offset
:= Value
;
1352 ---------------------------
1353 -- Set_Remotely_Callable --
1354 ---------------------------
1356 procedure Set_Remotely_Callable
(T
: Tag
; Value
: Boolean) is
1358 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1359 TSD
(T
).Remotely_Callable
:= Value
;
1360 end Set_Remotely_Callable
;
1366 procedure Set_SSD
(T
: Tag
; Value
: System
.Address
) is
1368 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1369 TSD
(T
).SSD_Ptr
:= Value
;
1372 ---------------------
1373 -- Set_Tagged_Kind --
1374 ---------------------
1376 procedure Set_Tagged_Kind
(T
: Tag
; Value
: Tagged_Kind
) is
1377 Tagged_Kind_Ptr
: constant System
.Address
:=
1378 To_Address
(T
) - K_Tagged_Kind
;
1380 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Secondary_DT
));
1381 To_Tagged_Kind_Ptr
(Tagged_Kind_Ptr
).all := Value
;
1382 end Set_Tagged_Kind
;
1388 procedure Set_TSD
(T
: Tag
; Value
: System
.Address
) is
1391 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Interface
));
1392 TSD_Ptr
:= To_Addr_Ptr
(To_Address
(T
) - K_Typeinfo
);
1393 TSD_Ptr
.all := Value
;
1400 function SSD
(T
: Tag
) return Select_Specific_Data_Ptr
is
1402 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_DT
));
1403 return To_Select_Specific_Data_Ptr
(TSD
(T
).SSD_Ptr
);
1410 function Typeinfo_Ptr
(T
: Tag
) return System
.Address
is
1411 TSD_Ptr
: constant Addr_Ptr
:=
1412 To_Addr_Ptr
(To_Address
(T
) - K_Typeinfo
);
1421 function TSD
(T
: Tag
) return Type_Specific_Data_Ptr
is
1422 TSD_Ptr
: constant Addr_Ptr
:=
1423 To_Addr_Ptr
(To_Address
(T
) - K_Typeinfo
);
1425 pragma Assert
(Check_Signature
(T
, Must_Be_Primary_Or_Interface
));
1426 return To_Type_Specific_Data_Ptr
(TSD_Ptr
.all);