1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
9 -- Copyright (C) 1992-2005, 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
48 No_Tag
: constant Tag
;
50 function Expanded_Name
(T
: Tag
) return String;
52 function External_Tag
(T
: Tag
) return String;
54 function Internal_Tag
(External
: String) return Tag
;
56 function Descendant_Tag
58 Ancestor
: Tag
) return Tag
;
59 pragma Ada_05
(Descendant_Tag
);
61 function Is_Descendant_At_Same_Level
63 Ancestor
: Tag
) return Boolean;
64 pragma Ada_05
(Is_Descendant_At_Same_Level
);
66 function Parent_Tag
(T
: Tag
) return Tag
;
67 pragma Ada_05
(Parent_Tag
);
69 Tag_Error
: exception;
71 function Wide_Expanded_Name
(T
: Tag
) return Wide_String;
72 pragma Ada_05
(Wide_Expanded_Name
);
74 function Wide_Wide_Expanded_Name
(T
: Tag
) return Wide_Wide_String
;
75 pragma Ada_05
(Wide_Wide_Expanded_Name
);
78 -- The following subprogram specifications are placed here instead of
79 -- the package body to see them from the frontend through rtsfind.
81 ---------------------------------------------------------------
82 -- Abstract Procedural Interface For The GNAT Dispatch Table --
83 ---------------------------------------------------------------
85 -- GNAT's Dispatch Table format is customizable in order to match the
86 -- format used in another language. GNAT supports programs that use two
87 -- different dispatch table formats at the same time: the native format
88 -- that supports Ada 95 tagged types and which is described in Ada.Tags,
89 -- and a foreign format for types that are imported from some other
90 -- language (typically C++) which is described in Interfaces.CPP. The
91 -- runtime information kept for each tagged type is separated into two
92 -- objects: the Dispatch Table and the Type Specific Data record. These
93 -- two objects are allocated statically using the constants:
95 -- DT Size = DT_Prologue_Size + Nb_Prim * DT_Entry_Size
96 -- TSD Size = TSD_Prologue_Size + (1 + Idepth) * TSD_Entry_Size
98 -- where Nb_prim is the number of primitive operations of the given
99 -- type and Idepth its inheritance depth.
101 -- In order to set or retrieve information from the Dispatch Table or
102 -- the Type Specific Data record, GNAT generates calls to Set_XXX or
103 -- Get_XXX routines, where XXX is the name of the field of interest.
106 type Tag
is access all Dispatch_Table
;
107 type Interface_Tag
is access all Dispatch_Table
;
109 No_Tag
: constant Tag
:= null;
111 type Interface_Data
(Nb_Ifaces
: Positive);
112 type Interface_Data_Ptr
is access all Interface_Data
;
113 -- Table of abstract interfaces used to give support to backward interface
114 -- conversions and also to IW_Membership.
116 type Object_Specific_Data
(Nb_Prim
: Positive);
117 type Object_Specific_Data_Ptr
is access all Object_Specific_Data
;
118 -- Information associated with the secondary dispatch table of tagged-type
119 -- objects implementing abstract interfaces.
121 type Select_Specific_Data
(Nb_Prim
: Positive);
122 type Select_Specific_Data_Ptr
is access all Select_Specific_Data
;
123 -- A table used to store the primitive operation kind and entry index of
124 -- primitive subprograms of a type that implements a limited interface.
125 -- The Select Specific Data table resides in the Type Specific Data of a
126 -- type. This construct is used in the handling of dispatching triggers
127 -- in select statements.
129 type Type_Specific_Data
;
130 type Type_Specific_Data_Ptr
is access all Type_Specific_Data
;
132 -- Primitive operation kinds. These values differentiate the kinds of
133 -- callable entities stored in the dispatch table. Certain kinds may
134 -- not be used, but are added for completeness.
140 POK_Protected_Function
,
141 POK_Protected_Procedure
,
146 -- Tagged type kinds with respect to concurrency and limitedness
149 (TK_Abstract_Limited_Tagged
,
156 type Tagged_Kind_Ptr
is access all Tagged_Kind
;
158 Default_Prim_Op_Count
: constant Positive := 15;
159 -- Number of predefined primitive operations added by the Expander for a
160 -- tagged type (must match Exp_Disp.Default_Prim_Op_Count).
162 type Signature_Kind
is
168 for Signature_Kind
'Size use 8;
169 -- Kind of signature found in the header of the dispatch table. These
170 -- signatures are generated by the frontend and are used by the Check_XXX
171 -- routines to ensure that the kind of dispatch table managed by each of
172 -- the routines in this package is correct. This additional check is only
173 -- performed with this run-time package is compiled with assertions enabled
175 -- The signature is a sequence of two bytes. The first byte must have the
176 -- value Valid_Signature, and the second byte must have a value in the
177 -- range Primary_DT .. Abstract_Interface. The Unknown value is used by
178 -- the Check_XXX routines to indicate that the signature is wrong.
180 package SSE
renames System
.Storage_Elements
;
182 function CW_Membership
(Obj_Tag
: Tag
; Typ_Tag
: Tag
) return Boolean;
183 -- Given the tag of an object and the tag associated to a type, return
184 -- true if Obj is in Typ'Class.
186 function IW_Membership
(This
: System
.Address
; T
: Tag
) return Boolean;
187 -- Ada 2005 (AI-251): General routine that checks if a given object
188 -- implements a tagged type. Its common usage is to check if Obj is in
189 -- Iface'Class, but it is also used to check if a class-wide interface
190 -- implements a given type (Iface_CW_Typ in T'Class). For example:
192 -- type I is interface;
193 -- type T is tagged ...
195 -- function Test (O : in I'Class) is
197 -- return O in T'Class.
200 function Displace
(This
: System
.Address
; T
: Tag
) return System
.Address
;
201 -- (Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch
204 function Get_Access_Level
(T
: Tag
) return Natural;
205 -- Given the tag associated with a type, returns the accessibility level
208 function Get_Entry_Index
(T
: Tag
; Position
: Positive) return Positive;
209 -- Return a primitive operation's entry index (if entry) given a dispatch
210 -- table T and a position of a primitive operation in T.
212 function Get_External_Tag
(T
: Tag
) return System
.Address
;
213 -- Retrieve the address of a null terminated string containing
214 -- the external name.
216 function Get_Offset_Index
218 Position
: Positive) return Positive;
219 -- Given a pointer to a secondary dispatch table (T) and a position of an
220 -- operation in the DT, retrieve the corresponding operation's position in
221 -- the primary dispatch table from the Offset Specific Data table of T.
223 function Get_Predefined_Prim_Op_Address
225 Position
: Positive) return System
.Address
;
226 -- Given a pointer to a dispatch table (T) and a position in the DT
227 -- this function returns the address of the virtual function stored
228 -- in it (used for dispatching calls).
230 function Get_Prim_Op_Address
232 Position
: Positive) return System
.Address
;
233 -- Given a pointer to a dispatch table (T) and a position in the DT
234 -- this function returns the address of the virtual function stored
235 -- in it (used for dispatching calls).
237 function Get_Prim_Op_Kind
239 Position
: Positive) return Prim_Op_Kind
;
240 -- Return a primitive operation's kind given a dispatch table T and a
241 -- position of a primitive operation in T.
243 function Get_RC_Offset
(T
: Tag
) return SSE
.Storage_Offset
;
244 -- Return the Offset of the implicit record controller when the object
245 -- has controlled components. O otherwise.
247 pragma Export
(Ada
, Get_RC_Offset
, "ada__tags__get_rc_offset");
248 -- This procedure is used in s-finimp to compute the deep routines
249 -- it is exported manually in order to avoid changing completely the
250 -- organization of the run time.
252 function Get_Remotely_Callable
(T
: Tag
) return Boolean;
253 -- Return the value previously set by Set_Remotely_Callable
255 function Get_Tagged_Kind
(T
: Tag
) return Tagged_Kind
;
256 -- Given a pointer to either a primary or a secondary dispatch table,
257 -- return the tagged kind of a type in the context of concurrency and
260 procedure Inherit_DT
(Old_T
: Tag
; New_T
: Tag
; Entry_Count
: Natural);
261 -- Entry point used to initialize the DT of a type knowing the tag
262 -- of the direct ancestor and the number of primitive ops that are
263 -- inherited (Entry_Count).
265 procedure Inherit_TSD
(Old_Tag
: Tag
; New_Tag
: Tag
);
266 -- Initialize the TSD of a type knowing the tag of the direct ancestor
268 function Offset_To_Top
269 (This
: System
.Address
) return System
.Storage_Elements
.Storage_Offset
;
270 -- Returns the current value of the offset_to_top component available in
271 -- the prologue of the dispatch table. If the parent of the tagged type
272 -- has discriminants this value is stored in a record component just
273 -- immediately after the tag component.
275 function OSD
(T
: Tag
) return Object_Specific_Data_Ptr
;
276 -- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table,
277 -- retrieve the address of the record containing the Objet Specific
281 (Obj
: System
.Address
;
282 T
: Tag
) return SSE
.Storage_Count
;
283 -- Computes the size the ancestor part of a tagged extension object whose
284 -- address is 'obj' by calling indirectly the ancestor _size function. The
285 -- ancestor is the parent of the type represented by tag T. This function
286 -- assumes that _size is always in slot one of the dispatch table.
288 pragma Export
(Ada
, Parent_Size
, "ada__tags__parent_size");
289 -- This procedure is used in s-finimp and is thus exported manually
291 procedure Register_Interface_Tag
294 Position
: Positive);
295 -- Ada 2005 (AI-251): Used to initialize the table of interfaces
296 -- implemented by a type. Required to give support to backward interface
297 -- conversions and also to IW_Membership.
299 procedure Register_Tag
(T
: Tag
);
300 -- Insert the Tag and its associated external_tag in a table for the
301 -- sake of Internal_Tag
303 procedure Set_Access_Level
(T
: Tag
; Value
: Natural);
304 -- Sets the accessibility level of the tagged type associated with T
307 procedure Set_Entry_Index
(T
: Tag
; Position
: Positive; Value
: Positive);
308 -- Set the entry index of a primitive operation in T's TSD table indexed
311 procedure Set_Expanded_Name
(T
: Tag
; Value
: System
.Address
);
312 -- Set the address of the string containing the expanded name
313 -- in the Dispatch table.
315 procedure Set_External_Tag
(T
: Tag
; Value
: System
.Address
);
316 -- Set the address of the string containing the external tag
317 -- in the Dispatch table.
319 procedure Set_Interface_Table
(T
: Tag
; Value
: System
.Address
);
320 -- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, stores the
321 -- pointer to the table of interfaces.
323 procedure Set_Num_Prim_Ops
(T
: Tag
; Value
: Natural);
324 -- Set the number of primitive operations in the dispatch table of T. This
325 -- is used for debugging purposes.
327 procedure Set_Offset_Index
331 -- Set the offset value of a primitive operation in a secondary dispatch
332 -- table denoted by T, indexed by Position.
334 procedure Set_Offset_To_Top
335 (This
: System
.Address
;
338 Offset_Value
: System
.Storage_Elements
.Storage_Offset
;
339 Offset_Func
: System
.Address
);
340 -- Ada 2005 (AI-251): Initialize the Offset_To_Top field in the prologue of
341 -- the dispatch table. In primary dispatch tables the value of "This" is
342 -- not required (and the compiler passes always the Null_Address value) and
343 -- the Offset_Value is always cero; in secondary dispatch tables "This"
344 -- points to the object, Interface_T is the interface for which the
345 -- secondary dispatch table is being initialized, and Offset_Value is the
346 -- distance from "This" to the object component containing the tag of the
347 -- secondary dispatch table.
349 procedure Set_OSD
(T
: Tag
; Value
: System
.Address
);
350 -- Given a pointer T to a secondary dispatch table, store the pointer to
351 -- the record containing the Object Specific Data generated by GNAT.
353 procedure Set_Predefined_Prim_Op_Address
356 Value
: System
.Address
);
357 -- Given a pointer to a dispatch Table (T) and a position in the dispatch
358 -- table associated with a predefined primitive operation, put the address
359 -- of the virtual function in it (used for overriding).
361 procedure Set_Prim_Op_Address
364 Value
: System
.Address
);
365 -- Given a pointer to a dispatch Table (T) and a position in the dispatch
366 -- Table put the address of the virtual function in it (used for
369 procedure Set_Prim_Op_Kind
372 Value
: Prim_Op_Kind
);
373 -- Set the kind of a primitive operation in T's TSD table indexed by
376 procedure Set_RC_Offset
(T
: Tag
; Value
: SSE
.Storage_Offset
);
377 -- Sets the Offset of the implicit record controller when the object
378 -- has controlled components. Set to O otherwise.
380 procedure Set_Remotely_Callable
(T
: Tag
; Value
: Boolean);
381 -- Set to true if the type has been declared in a context described
384 procedure Set_Signature
(T
: Tag
; Value
: Signature_Kind
);
385 -- Given a pointer T to a dispatch table, store the signature id
387 procedure Set_SSD
(T
: Tag
; Value
: System
.Address
);
388 -- Given a pointer T to a dispatch Table, stores the pointer to the record
389 -- containing the Select Specific Data generated by GNAT.
391 procedure Set_Tagged_Kind
(T
: Tag
; Value
: Tagged_Kind
);
392 -- Set the tagged kind of a type in either a primary or a secondary
393 -- dispatch table denoted by T.
395 procedure Set_TSD
(T
: Tag
; Value
: System
.Address
);
396 -- Given a pointer T to a dispatch Table, stores the address of the record
397 -- containing the Type Specific Data generated by GNAT.
399 function SSD
(T
: Tag
) return Select_Specific_Data_Ptr
;
400 -- Given a pointer T to a dispatch Table, retrieves the address of the
401 -- record containing the Select Specific Data in T's TSD.
403 function TSD
(T
: Tag
) return Type_Specific_Data_Ptr
;
404 -- Given a pointer T to a dispatch Table, retrieves the address of the
405 -- record containing the Type Specific Data generated by GNAT.
407 DT_Prologue_Size
: constant SSE
.Storage_Count
:=
409 ((Default_Prim_Op_Count
+ 4) *
410 (Standard
'Address_Size / System
.Storage_Unit
));
411 -- Size of the hidden part of the dispatch table. It contains the table of
412 -- predefined primitive operations plus the C++ ABI header.
414 DT_Signature_Size
: constant SSE
.Storage_Count
:=
416 (1 * (Standard
'Address_Size / System
.Storage_Unit
));
417 -- Size of the Signature field of the dispatch table
419 DT_Tagged_Kind_Size
: constant SSE
.Storage_Count
:=
420 SSE
.Storage_Count
(1 * (Standard
'Address_Size / System
.Storage_Unit
));
421 -- Size of the Tagged_Type_Kind field of the dispatch table
423 DT_Offset_To_Top_Size
: constant SSE
.Storage_Count
:=
425 (1 * (Standard
'Address_Size /
426 System
.Storage_Unit
));
427 -- Size of the Offset_To_Top field of the Dispatch Table
429 DT_Typeinfo_Ptr_Size
: constant SSE
.Storage_Count
:=
431 (1 * (Standard
'Address_Size /
432 System
.Storage_Unit
));
433 -- Size of the Typeinfo_Ptr field of the Dispatch Table
435 DT_Entry_Size
: constant SSE
.Storage_Count
:=
437 (1 * (Standard
'Address_Size / System
.Storage_Unit
));
438 -- Size of each primitive operation entry in the Dispatch Table
440 Tag_Size
: constant SSE
.Storage_Count
:=
441 SSE
.Storage_Count
(1 * (Standard
'Address_Size / System
.Storage_Unit
));
444 TSD_Prologue_Size
: constant SSE
.Storage_Count
:=
446 (10 * (Standard
'Address_Size /
447 System
.Storage_Unit
));
448 -- Size of the first part of the type specific data
450 TSD_Entry_Size
: constant SSE
.Storage_Count
:=
452 (1 * (Standard
'Address_Size / System
.Storage_Unit
));
453 -- Size of each ancestor tag entry in the TSD
455 type Address_Array
is array (Natural range <>) of System
.Address
;
456 pragma Suppress
(Index_Check
, On
=> Address_Array
);
457 -- The reason we suppress index checks is that in the body, objects
458 -- of this type are declared with a dummy size of 1, the actual size
459 -- depending on the number of primitive operations.
461 -- Unchecked Conversions
463 type Addr_Ptr
is access System
.Address
;
464 type Tag_Ptr
is access Tag
;
466 type Signature_Values
is
467 array (1 .. DT_Signature_Size
) of Signature_Kind
;
468 -- Type used to see the signature as a sequence of Signature_Kind values
470 type Signature_Values_Ptr
is access all Signature_Values
;
472 function To_Addr_Ptr
is
473 new Unchecked_Conversion
(System
.Address
, Addr_Ptr
);
475 function To_Type_Specific_Data_Ptr
is
476 new Unchecked_Conversion
(System
.Address
, Type_Specific_Data_Ptr
);
478 function To_Address
is
479 new Unchecked_Conversion
(Interface_Tag
, System
.Address
);
481 function To_Address
is
482 new Unchecked_Conversion
(Tag
, System
.Address
);
484 function To_Address
is
485 new Unchecked_Conversion
(Type_Specific_Data_Ptr
, System
.Address
);
487 function To_Interface_Data_Ptr
is
488 new Unchecked_Conversion
(System
.Address
, Interface_Data_Ptr
);
490 function To_Object_Specific_Data_Ptr
is
491 new Unchecked_Conversion
(System
.Address
, Object_Specific_Data_Ptr
);
493 function To_Select_Specific_Data_Ptr
is
494 new Unchecked_Conversion
(System
.Address
, Select_Specific_Data_Ptr
);
496 function To_Signature_Values
is
497 new Unchecked_Conversion
(System
.Storage_Elements
.Storage_Offset
,
500 function To_Signature_Values_Ptr
is
501 new Unchecked_Conversion
(System
.Address
,
502 Signature_Values_Ptr
);
505 new Unchecked_Conversion
(System
.Address
, Tag
);
507 function To_Tag_Ptr
is
508 new Unchecked_Conversion
(System
.Address
, Tag_Ptr
);
510 function To_Tagged_Kind_Ptr
is
511 new Unchecked_Conversion
(System
.Address
, Tagged_Kind_Ptr
);
513 -- Primitive dispatching operations are always inlined, to facilitate
514 -- use in a minimal/no run-time environment for high integrity use.
516 pragma Inline_Always
(CW_Membership
);
517 pragma Inline_Always
(Displace
);
518 pragma Inline_Always
(IW_Membership
);
519 pragma Inline_Always
(Get_Access_Level
);
520 pragma Inline_Always
(Get_Entry_Index
);
521 pragma Inline_Always
(Get_Offset_Index
);
522 pragma Inline_Always
(Get_Predefined_Prim_Op_Address
);
523 pragma Inline_Always
(Get_Prim_Op_Address
);
524 pragma Inline_Always
(Get_Prim_Op_Kind
);
525 pragma Inline_Always
(Get_RC_Offset
);
526 pragma Inline_Always
(Get_Remotely_Callable
);
527 pragma Inline_Always
(Get_Tagged_Kind
);
528 pragma Inline_Always
(Inherit_DT
);
529 pragma Inline_Always
(Inherit_TSD
);
530 pragma Inline_Always
(OSD
);
531 pragma Inline_Always
(Register_Interface_Tag
);
532 pragma Inline_Always
(Register_Tag
);
533 pragma Inline_Always
(Set_Access_Level
);
534 pragma Inline_Always
(Set_Entry_Index
);
535 pragma Inline_Always
(Set_Expanded_Name
);
536 pragma Inline_Always
(Set_External_Tag
);
537 pragma Inline_Always
(Set_Interface_Table
);
538 pragma Inline_Always
(Set_Num_Prim_Ops
);
539 pragma Inline_Always
(Set_Offset_Index
);
540 pragma Inline_Always
(Set_Offset_To_Top
);
541 pragma Inline_Always
(Set_Predefined_Prim_Op_Address
);
542 pragma Inline_Always
(Set_Prim_Op_Address
);
543 pragma Inline_Always
(Set_Prim_Op_Kind
);
544 pragma Inline_Always
(Set_RC_Offset
);
545 pragma Inline_Always
(Set_Remotely_Callable
);
546 pragma Inline_Always
(Set_Signature
);
547 pragma Inline_Always
(Set_OSD
);
548 pragma Inline_Always
(Set_SSD
);
549 pragma Inline_Always
(Set_TSD
);
550 pragma Inline_Always
(Set_Tagged_Kind
);
551 pragma Inline_Always
(SSD
);
552 pragma Inline_Always
(TSD
);