1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
9 -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
11 -- This specification is derived from the Ada Reference Manual for use with --
12 -- GNAT. The copyright notice above, and the license provisions that follow --
13 -- apply solely to the contents of the part following the private keyword. --
15 -- GNAT is free software; you can redistribute it and/or modify it under --
16 -- terms of the GNU General Public License as published by the Free Soft- --
17 -- ware Foundation; either version 2, or (at your option) any later ver- --
18 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
19 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
20 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
21 -- for more details. You should have received a copy of the GNU General --
22 -- Public License distributed with GNAT; see file COPYING. If not, write --
23 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
24 -- Boston, MA 02110-1301, USA. --
26 -- As a special exception, if other files instantiate generics from this --
27 -- unit, or you link this unit with other files to produce an executable, --
28 -- this unit does not by itself cause the resulting executable to be --
29 -- covered by the GNU General Public License. This exception does not --
30 -- however invalidate any other reasons why the executable file might be --
31 -- covered by the GNU Public License. --
33 -- GNAT was originally developed by the GNAT team at New York University. --
34 -- Extensive contributions were provided by Ada Core Technologies Inc. --
36 ------------------------------------------------------------------------------
39 with System
.Storage_Elements
;
40 with Unchecked_Conversion
;
43 pragma Preelaborate_05
;
44 -- In accordance with Ada 2005 AI-362
47 pragma Preelaborable_Initialization
(Tag
);
49 No_Tag
: constant Tag
;
51 function Expanded_Name
(T
: Tag
) return String;
53 function Wide_Expanded_Name
(T
: Tag
) return Wide_String;
54 pragma Ada_05
(Wide_Expanded_Name
);
56 function Wide_Wide_Expanded_Name
(T
: Tag
) return Wide_Wide_String
;
57 pragma Ada_05
(Wide_Wide_Expanded_Name
);
59 function External_Tag
(T
: Tag
) return String;
61 function Internal_Tag
(External
: String) return Tag
;
63 function Descendant_Tag
65 Ancestor
: Tag
) return Tag
;
66 pragma Ada_05
(Descendant_Tag
);
68 function Is_Descendant_At_Same_Level
70 Ancestor
: Tag
) return Boolean;
71 pragma Ada_05
(Is_Descendant_At_Same_Level
);
73 function Parent_Tag
(T
: Tag
) return Tag
;
74 pragma Ada_05
(Parent_Tag
);
76 type Tag_Array
is array (Positive range <>) of Tag
;
78 function Interface_Ancestor_Tags
(T
: Tag
) return Tag_Array
;
79 pragma Ada_05
(Interface_Ancestor_Tags
);
81 Tag_Error
: exception;
84 -- The following subprogram specifications are placed here instead of
85 -- the package body to see them from the frontend through rtsfind.
87 ---------------------------------------------------------------
88 -- Abstract Procedural Interface For The GNAT Dispatch Table --
89 ---------------------------------------------------------------
91 -- GNAT's Dispatch Table format is customizable in order to match the
92 -- format used in another language. GNAT supports programs that use two
93 -- different dispatch table formats at the same time: the native format
94 -- that supports Ada 95 tagged types and which is described in Ada.Tags,
95 -- and a foreign format for types that are imported from some other
96 -- language (typically C++) which is described in Interfaces.CPP. The
97 -- runtime information kept for each tagged type is separated into two
98 -- objects: the Dispatch Table and the Type Specific Data record. These
99 -- two objects are allocated statically using the constants:
101 -- DT Size = DT_Prologue_Size + Nb_Prim * DT_Entry_Size
102 -- TSD Size = TSD_Prologue_Size + (1 + Idepth) * TSD_Entry_Size
104 -- where Nb_prim is the number of primitive operations of the given
105 -- type and Idepth its inheritance depth.
107 -- In order to set or retrieve information from the Dispatch Table or
108 -- the Type Specific Data record, GNAT generates calls to Set_XXX or
109 -- Get_XXX routines, where XXX is the name of the field of interest.
112 type Tag
is access all Dispatch_Table
;
113 type Interface_Tag
is access all Dispatch_Table
;
115 No_Tag
: constant Tag
:= null;
117 type Interface_Data
(Nb_Ifaces
: Positive);
118 type Interface_Data_Ptr
is access all Interface_Data
;
119 -- Table of abstract interfaces used to give support to backward interface
120 -- conversions and also to IW_Membership.
122 type Object_Specific_Data
(Nb_Prim
: Positive);
123 type Object_Specific_Data_Ptr
is access all Object_Specific_Data
;
124 -- Information associated with the secondary dispatch table of tagged-type
125 -- objects implementing abstract interfaces.
127 type Select_Specific_Data
(Nb_Prim
: Positive);
128 type Select_Specific_Data_Ptr
is access all Select_Specific_Data
;
129 -- A table used to store the primitive operation kind and entry index of
130 -- primitive subprograms of a type that implements a limited interface.
131 -- The Select Specific Data table resides in the Type Specific Data of a
132 -- type. This construct is used in the handling of dispatching triggers
133 -- in select statements.
135 type Type_Specific_Data
;
136 type Type_Specific_Data_Ptr
is access all Type_Specific_Data
;
138 -- Primitive operation kinds. These values differentiate the kinds of
139 -- callable entities stored in the dispatch table. Certain kinds may
140 -- not be used, but are added for completeness.
146 POK_Protected_Function
,
147 POK_Protected_Procedure
,
152 -- Tagged type kinds with respect to concurrency and limitedness
155 (TK_Abstract_Limited_Tagged
,
162 type Tagged_Kind_Ptr
is access all Tagged_Kind
;
164 Default_Prim_Op_Count
: constant Positive := 15;
165 -- Number of predefined primitive operations added by the Expander for a
166 -- tagged type (must match Exp_Disp.Default_Prim_Op_Count).
168 type Signature_Kind
is
174 for Signature_Kind
'Size use 8;
175 -- Kind of signature found in the header of the dispatch table. These
176 -- signatures are generated by the frontend and are used by the Check_XXX
177 -- routines to ensure that the kind of dispatch table managed by each of
178 -- the routines in this package is correct. This additional check is only
179 -- performed with this run-time package is compiled with assertions enabled
181 -- The signature is a sequence of two bytes. The first byte must have the
182 -- value Valid_Signature, and the second byte must have a value in the
183 -- range Primary_DT .. Abstract_Interface. The Unknown value is used by
184 -- the Check_XXX routines to indicate that the signature is wrong.
186 package SSE
renames System
.Storage_Elements
;
188 function CW_Membership
(Obj_Tag
: Tag
; Typ_Tag
: Tag
) return Boolean;
189 -- Given the tag of an object and the tag associated to a type, return
190 -- true if Obj is in Typ'Class.
192 function IW_Membership
(This
: System
.Address
; T
: Tag
) return Boolean;
193 -- Ada 2005 (AI-251): General routine that checks if a given object
194 -- implements a tagged type. Its common usage is to check if Obj is in
195 -- Iface'Class, but it is also used to check if a class-wide interface
196 -- implements a given type (Iface_CW_Typ in T'Class). For example:
198 -- type I is interface;
199 -- type T is tagged ...
201 -- function Test (O : I'Class) is
203 -- return O in T'Class.
206 function Displace
(This
: System
.Address
; T
: Tag
) return System
.Address
;
207 -- (Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch
210 function Get_Access_Level
(T
: Tag
) return Natural;
211 -- Given the tag associated with a type, returns the accessibility level
214 function Get_Entry_Index
(T
: Tag
; Position
: Positive) return Positive;
215 -- Return a primitive operation's entry index (if entry) given a dispatch
216 -- table T and a position of a primitive operation in T.
218 function Get_External_Tag
(T
: Tag
) return System
.Address
;
219 -- Retrieve the address of a null terminated string containing
220 -- the external name.
222 function Get_Offset_Index
224 Position
: Positive) return Positive;
225 -- Given a pointer to a secondary dispatch table (T) and a position of an
226 -- operation in the DT, retrieve the corresponding operation's position in
227 -- the primary dispatch table from the Offset Specific Data table of T.
229 function Get_Predefined_Prim_Op_Address
231 Position
: Positive) return System
.Address
;
232 -- Given a pointer to a dispatch table (T) and a position in the DT
233 -- this function returns the address of the virtual function stored
234 -- in it (used for dispatching calls).
236 function Get_Prim_Op_Address
238 Position
: Positive) return System
.Address
;
239 -- Given a pointer to a dispatch table (T) and a position in the DT
240 -- this function returns the address of the virtual function stored
241 -- in it (used for dispatching calls).
243 function Get_Prim_Op_Kind
245 Position
: Positive) return Prim_Op_Kind
;
246 -- Return a primitive operation's kind given a dispatch table T and a
247 -- position of a primitive operation in T.
249 function Get_RC_Offset
(T
: Tag
) return SSE
.Storage_Offset
;
250 -- Return the Offset of the implicit record controller when the object
251 -- has controlled components. O otherwise.
253 pragma Export
(Ada
, Get_RC_Offset
, "ada__tags__get_rc_offset");
254 -- This procedure is used in s-finimp to compute the deep routines
255 -- it is exported manually in order to avoid changing completely the
256 -- organization of the run time.
258 function Get_Remotely_Callable
(T
: Tag
) return Boolean;
259 -- Return the value previously set by Set_Remotely_Callable
261 function Get_Tagged_Kind
(T
: Tag
) return Tagged_Kind
;
262 -- Given a pointer to either a primary or a secondary dispatch table,
263 -- return the tagged kind of a type in the context of concurrency and
266 procedure Inherit_CPP_DT
(Old_T
: Tag
; New_T
: Tag
; Entry_Count
: Natural);
267 -- Entry point used to initialize the DT of a type knowing the tag
268 -- of the direct CPP ancestor and the number of primitive ops that
269 -- are inherited (Entry_Count).
271 procedure Inherit_DT
(Old_T
: Tag
; New_T
: Tag
; Entry_Count
: Natural);
272 -- Entry point used to initialize the DT of a type knowing the tag
273 -- of the direct ancestor and the number of primitive ops that are
274 -- inherited (Entry_Count).
276 procedure Inherit_TSD
(Old_Tag
: Tag
; New_Tag
: Tag
);
277 -- Initialize the TSD of a type knowing the tag of the direct ancestor
279 function Offset_To_Top
280 (This
: System
.Address
) return System
.Storage_Elements
.Storage_Offset
;
281 -- Returns the current value of the offset_to_top component available in
282 -- the prologue of the dispatch table. If the parent of the tagged type
283 -- has discriminants this value is stored in a record component just
284 -- immediately after the tag component.
286 function OSD
(T
: Tag
) return Object_Specific_Data_Ptr
;
287 -- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table,
288 -- retrieve the address of the record containing the Objet Specific
292 (Obj
: System
.Address
;
293 T
: Tag
) return SSE
.Storage_Count
;
294 -- Computes the size the ancestor part of a tagged extension object whose
295 -- address is 'obj' by calling indirectly the ancestor _size function. The
296 -- ancestor is the parent of the type represented by tag T. This function
297 -- assumes that _size is always in slot one of the dispatch table.
299 pragma Export
(Ada
, Parent_Size
, "ada__tags__parent_size");
300 -- This procedure is used in s-finimp and is thus exported manually
302 procedure Register_Interface_Tag
305 Position
: Positive);
306 -- Ada 2005 (AI-251): Used to initialize the table of interfaces
307 -- implemented by a type. Required to give support to backward interface
308 -- conversions and also to IW_Membership.
310 procedure Register_Tag
(T
: Tag
);
311 -- Insert the Tag and its associated external_tag in a table for the
312 -- sake of Internal_Tag
314 procedure Set_Access_Level
(T
: Tag
; Value
: Natural);
315 -- Sets the accessibility level of the tagged type associated with T
318 procedure Set_Entry_Index
(T
: Tag
; Position
: Positive; Value
: Positive);
319 -- Set the entry index of a primitive operation in T's TSD table indexed
322 procedure Set_Expanded_Name
(T
: Tag
; Value
: System
.Address
);
323 -- Set the address of the string containing the expanded name
324 -- in the Dispatch table.
326 procedure Set_External_Tag
(T
: Tag
; Value
: System
.Address
);
327 -- Set the address of the string containing the external tag
328 -- in the Dispatch table.
330 procedure Set_Interface_Table
(T
: Tag
; Value
: System
.Address
);
331 -- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, stores the
332 -- pointer to the table of interfaces.
334 procedure Set_Num_Prim_Ops
(T
: Tag
; Value
: Natural);
335 -- Set the number of primitive operations in the dispatch table of T. This
336 -- is used for debugging purposes.
338 procedure Set_Offset_Index
342 -- Set the offset value of a primitive operation in a secondary dispatch
343 -- table denoted by T, indexed by Position.
345 procedure Set_Offset_To_Top
346 (This
: System
.Address
;
349 Offset_Value
: System
.Storage_Elements
.Storage_Offset
;
350 Offset_Func
: System
.Address
);
351 -- Ada 2005 (AI-251): Initialize the Offset_To_Top field in the prologue of
352 -- the dispatch table. In primary dispatch tables the value of "This" is
353 -- not required (and the compiler passes always the Null_Address value) and
354 -- the Offset_Value is always cero; in secondary dispatch tables "This"
355 -- points to the object, Interface_T is the interface for which the
356 -- secondary dispatch table is being initialized, and Offset_Value is the
357 -- distance from "This" to the object component containing the tag of the
358 -- secondary dispatch table.
360 procedure Set_OSD
(T
: Tag
; Value
: System
.Address
);
361 -- Given a pointer T to a secondary dispatch table, store the pointer to
362 -- the record containing the Object Specific Data generated by GNAT.
364 procedure Set_Predefined_Prim_Op_Address
367 Value
: System
.Address
);
368 -- Given a pointer to a dispatch Table (T) and a position in the dispatch
369 -- table associated with a predefined primitive operation, put the address
370 -- of the virtual function in it (used for overriding).
372 procedure Set_Prim_Op_Address
375 Value
: System
.Address
);
376 -- Given a pointer to a dispatch Table (T) and a position in the dispatch
377 -- Table put the address of the virtual function in it (used for
380 procedure Set_Prim_Op_Kind
383 Value
: Prim_Op_Kind
);
384 -- Set the kind of a primitive operation in T's TSD table indexed by
387 procedure Set_RC_Offset
(T
: Tag
; Value
: SSE
.Storage_Offset
);
388 -- Sets the Offset of the implicit record controller when the object
389 -- has controlled components. Set to O otherwise.
391 procedure Set_Remotely_Callable
(T
: Tag
; Value
: Boolean);
392 -- Set to true if the type has been declared in a context described
395 procedure Set_Signature
(T
: Tag
; Value
: Signature_Kind
);
396 -- Given a pointer T to a dispatch table, store the signature id
398 procedure Set_SSD
(T
: Tag
; Value
: System
.Address
);
399 -- Given a pointer T to a dispatch Table, stores the pointer to the record
400 -- containing the Select Specific Data generated by GNAT.
402 procedure Set_Tagged_Kind
(T
: Tag
; Value
: Tagged_Kind
);
403 -- Set the tagged kind of a type in either a primary or a secondary
404 -- dispatch table denoted by T.
406 procedure Set_TSD
(T
: Tag
; Value
: System
.Address
);
407 -- Given a pointer T to a dispatch Table, stores the address of the record
408 -- containing the Type Specific Data generated by GNAT.
410 function SSD
(T
: Tag
) return Select_Specific_Data_Ptr
;
411 -- Given a pointer T to a dispatch Table, retrieves the address of the
412 -- record containing the Select Specific Data in T's TSD.
414 function TSD
(T
: Tag
) return Type_Specific_Data_Ptr
;
415 -- Given a pointer T to a dispatch Table, retrieves the address of the
416 -- record containing the Type Specific Data generated by GNAT.
418 DT_Prologue_Size
: constant SSE
.Storage_Count
:=
420 ((Default_Prim_Op_Count
+ 4) *
421 (Standard
'Address_Size / System
.Storage_Unit
));
422 -- Size of the hidden part of the dispatch table. It contains the table of
423 -- predefined primitive operations plus the C++ ABI header.
425 DT_Signature_Size
: constant SSE
.Storage_Count
:=
427 (1 * (Standard
'Address_Size / System
.Storage_Unit
));
428 -- Size of the Signature field of the dispatch table
430 DT_Tagged_Kind_Size
: constant SSE
.Storage_Count
:=
431 SSE
.Storage_Count
(1 * (Standard
'Address_Size / System
.Storage_Unit
));
432 -- Size of the Tagged_Type_Kind field of the dispatch table
434 DT_Offset_To_Top_Size
: constant SSE
.Storage_Count
:=
436 (1 * (Standard
'Address_Size /
437 System
.Storage_Unit
));
438 -- Size of the Offset_To_Top field of the Dispatch Table
440 DT_Typeinfo_Ptr_Size
: constant SSE
.Storage_Count
:=
442 (1 * (Standard
'Address_Size /
443 System
.Storage_Unit
));
444 -- Size of the Typeinfo_Ptr field of the Dispatch Table
446 DT_Entry_Size
: constant SSE
.Storage_Count
:=
448 (1 * (Standard
'Address_Size / System
.Storage_Unit
));
449 -- Size of each primitive operation entry in the Dispatch Table
451 Tag_Size
: constant SSE
.Storage_Count
:=
452 SSE
.Storage_Count
(1 * (Standard
'Address_Size / System
.Storage_Unit
));
455 TSD_Prologue_Size
: constant SSE
.Storage_Count
:=
457 (10 * (Standard
'Address_Size /
458 System
.Storage_Unit
));
459 -- Size of the first part of the type specific data
461 TSD_Entry_Size
: constant SSE
.Storage_Count
:=
463 (1 * (Standard
'Address_Size / System
.Storage_Unit
));
464 -- Size of each ancestor tag entry in the TSD
466 type Address_Array
is array (Natural range <>) of System
.Address
;
467 pragma Suppress
(Index_Check
, On
=> Address_Array
);
468 -- The reason we suppress index checks is that in the body, objects
469 -- of this type are declared with a dummy size of 1, the actual size
470 -- depending on the number of primitive operations.
472 -- Unchecked Conversions
474 type Addr_Ptr
is access System
.Address
;
475 type Tag_Ptr
is access Tag
;
477 type Signature_Values
is
478 array (1 .. DT_Signature_Size
) of Signature_Kind
;
479 -- Type used to see the signature as a sequence of Signature_Kind values
481 type Signature_Values_Ptr
is access all Signature_Values
;
483 function To_Addr_Ptr
is
484 new Unchecked_Conversion
(System
.Address
, Addr_Ptr
);
486 function To_Type_Specific_Data_Ptr
is
487 new Unchecked_Conversion
(System
.Address
, Type_Specific_Data_Ptr
);
489 function To_Address
is
490 new Unchecked_Conversion
(Interface_Tag
, System
.Address
);
492 function To_Address
is
493 new Unchecked_Conversion
(Tag
, System
.Address
);
495 function To_Address
is
496 new Unchecked_Conversion
(Type_Specific_Data_Ptr
, System
.Address
);
498 function To_Interface_Data_Ptr
is
499 new Unchecked_Conversion
(System
.Address
, Interface_Data_Ptr
);
501 function To_Object_Specific_Data_Ptr
is
502 new Unchecked_Conversion
(System
.Address
, Object_Specific_Data_Ptr
);
504 function To_Select_Specific_Data_Ptr
is
505 new Unchecked_Conversion
(System
.Address
, Select_Specific_Data_Ptr
);
507 function To_Signature_Values
is
508 new Unchecked_Conversion
(System
.Storage_Elements
.Storage_Offset
,
511 function To_Signature_Values_Ptr
is
512 new Unchecked_Conversion
(System
.Address
,
513 Signature_Values_Ptr
);
516 new Unchecked_Conversion
(System
.Address
, Tag
);
518 function To_Tag_Ptr
is
519 new Unchecked_Conversion
(System
.Address
, Tag_Ptr
);
521 function To_Tagged_Kind_Ptr
is
522 new Unchecked_Conversion
(System
.Address
, Tagged_Kind_Ptr
);
524 -- Primitive dispatching operations are always inlined, to facilitate
525 -- use in a minimal/no run-time environment for high integrity use.
527 pragma Inline_Always
(CW_Membership
);
528 pragma Inline_Always
(Displace
);
529 pragma Inline_Always
(IW_Membership
);
530 pragma Inline_Always
(Get_Access_Level
);
531 pragma Inline_Always
(Get_Entry_Index
);
532 pragma Inline_Always
(Get_Offset_Index
);
533 pragma Inline_Always
(Get_Predefined_Prim_Op_Address
);
534 pragma Inline_Always
(Get_Prim_Op_Address
);
535 pragma Inline_Always
(Get_Prim_Op_Kind
);
536 pragma Inline_Always
(Get_RC_Offset
);
537 pragma Inline_Always
(Get_Remotely_Callable
);
538 pragma Inline_Always
(Get_Tagged_Kind
);
539 pragma Inline_Always
(Inherit_DT
);
540 pragma Inline_Always
(Inherit_TSD
);
541 pragma Inline_Always
(OSD
);
542 pragma Inline_Always
(Register_Interface_Tag
);
543 pragma Inline_Always
(Register_Tag
);
544 pragma Inline_Always
(Set_Access_Level
);
545 pragma Inline_Always
(Set_Entry_Index
);
546 pragma Inline_Always
(Set_Expanded_Name
);
547 pragma Inline_Always
(Set_External_Tag
);
548 pragma Inline_Always
(Set_Interface_Table
);
549 pragma Inline_Always
(Set_Num_Prim_Ops
);
550 pragma Inline_Always
(Set_Offset_Index
);
551 pragma Inline_Always
(Set_Offset_To_Top
);
552 pragma Inline_Always
(Set_Predefined_Prim_Op_Address
);
553 pragma Inline_Always
(Set_Prim_Op_Address
);
554 pragma Inline_Always
(Set_Prim_Op_Kind
);
555 pragma Inline_Always
(Set_RC_Offset
);
556 pragma Inline_Always
(Set_Remotely_Callable
);
557 pragma Inline_Always
(Set_Signature
);
558 pragma Inline_Always
(Set_OSD
);
559 pragma Inline_Always
(Set_SSD
);
560 pragma Inline_Always
(Set_TSD
);
561 pragma Inline_Always
(Set_Tagged_Kind
);
562 pragma Inline_Always
(SSD
);
563 pragma Inline_Always
(TSD
);