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;
72 -- The following subprogram specifications are placed here instead of
73 -- the package body to see them from the frontend through rtsfind.
75 ---------------------------------------------------------------
76 -- Abstract Procedural Interface For The GNAT Dispatch Table --
77 ---------------------------------------------------------------
79 -- GNAT's Dispatch Table format is customizable in order to match the
80 -- format used in another language. GNAT supports programs that use two
81 -- different dispatch table formats at the same time: the native format
82 -- that supports Ada 95 tagged types and which is described in Ada.Tags,
83 -- and a foreign format for types that are imported from some other
84 -- language (typically C++) which is described in Interfaces.CPP. The
85 -- runtime information kept for each tagged type is separated into two
86 -- objects: the Dispatch Table and the Type Specific Data record. These
87 -- two objects are allocated statically using the constants:
89 -- DT Size = DT_Prologue_Size + Nb_Prim * DT_Entry_Size
90 -- TSD Size = TSD_Prologue_Size + (1 + Idepth) * TSD_Entry_Size
92 -- where Nb_prim is the number of primitive operations of the given
93 -- type and Idepth its inheritance depth.
95 -- In order to set or retrieve information from the Dispatch Table or
96 -- the Type Specific Data record, GNAT generates calls to Set_XXX or
97 -- Get_XXX routines, where XXX is the name of the field of interest.
100 type Tag
is access all Dispatch_Table
;
101 type Interface_Tag
is access all Dispatch_Table
;
103 No_Tag
: constant Tag
:= null;
105 type Interface_Data
(Nb_Ifaces
: Positive);
106 type Interface_Data_Ptr
is access all Interface_Data
;
107 -- Table of abstract interfaces used to give support to backward interface
108 -- conversions and also to IW_Membership.
110 type Object_Specific_Data
(Nb_Prim
: Positive);
111 type Object_Specific_Data_Ptr
is access all Object_Specific_Data
;
112 -- Information associated with the secondary dispatch table of tagged-type
113 -- objects implementing abstract interfaces.
115 type Select_Specific_Data
(Nb_Prim
: Positive);
116 type Select_Specific_Data_Ptr
is access all Select_Specific_Data
;
117 -- A table used to store the primitive operation kind and entry index of
118 -- primitive subprograms of a type that implements a limited interface.
119 -- The Select Specific Data table resides in the Type Specific Data of a
120 -- type. This construct is used in the handling of dispatching triggers
121 -- in select statements.
123 type Type_Specific_Data
;
124 type Type_Specific_Data_Ptr
is access all Type_Specific_Data
;
126 -- Primitive operation kinds. These values differentiate the kinds of
127 -- callable entities stored in the dispatch table. Certain kinds may
128 -- not be used, but are added for completeness.
134 POK_Protected_Function
,
135 POK_Protected_Procedure
,
140 -- Tagged type kinds with respect to concurrency and limitedness
143 (TK_Abstract_Limited_Tagged
,
150 type Tagged_Kind_Ptr
is access all Tagged_Kind
;
152 Default_Prim_Op_Count
: constant Positive := 15;
153 -- Number of predefined primitive operations added by the Expander for a
154 -- tagged type. It is utilized for indexing in the two auxiliary tables
155 -- used for dispatching asynchronous, conditional and timed selects. In
156 -- order to be space efficient, indexing is performed by subtracting this
157 -- constant value from the provided position in the auxiliary tables (must
158 -- match Exp_Disp.Default_Prim_Op_Count).
160 package SSE
renames System
.Storage_Elements
;
162 function CW_Membership
(Obj_Tag
: Tag
; Typ_Tag
: Tag
) return Boolean;
163 -- Given the tag of an object and the tag associated to a type, return
164 -- true if Obj is in Typ'Class.
166 function IW_Membership
(This
: System
.Address
; T
: Tag
) return Boolean;
167 -- Ada 2005 (AI-251): General routine that checks if a given object
168 -- implements a tagged type. Its common usage is to check if Obj is in
169 -- Iface'Class, but it is also used to check if a class-wide interface
170 -- implements a given type (Iface_CW_Typ in T'Class). For example:
172 -- type I is interface;
173 -- type T is tagged ...
175 -- function Test (O : in I'Class) is
177 -- return O in T'Class.
180 function Displace
(This
: System
.Address
; T
: Tag
) return System
.Address
;
181 -- (Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch
184 function Get_Access_Level
(T
: Tag
) return Natural;
185 -- Given the tag associated with a type, returns the accessibility level
188 function Get_Entry_Index
(T
: Tag
; Position
: Positive) return Positive;
189 -- Return a primitive operation's entry index (if entry) given a dispatch
190 -- table T and a position of a primitive operation in T.
192 function Get_External_Tag
(T
: Tag
) return System
.Address
;
193 -- Retrieve the address of a null terminated string containing
194 -- the external name.
196 function Get_Offset_Index
198 Position
: Positive) return Positive;
199 -- Given a pointer to a secondary dispatch table (T) and a position of an
200 -- operation in the DT, retrieve the corresponding operation's position in
201 -- the primary dispatch table from the Offset Specific Data table of T.
203 function Get_Prim_Op_Address
205 Position
: Positive) return System
.Address
;
206 -- Given a pointer to a dispatch table (T) and a position in the DT
207 -- this function returns the address of the virtual function stored
208 -- in it (used for dispatching calls).
210 function Get_Prim_Op_Kind
212 Position
: Positive) return Prim_Op_Kind
;
213 -- Return a primitive operation's kind given a dispatch table T and a
214 -- position of a primitive operation in T.
216 function Get_RC_Offset
(T
: Tag
) return SSE
.Storage_Offset
;
217 -- Return the Offset of the implicit record controller when the object
218 -- has controlled components. O otherwise.
220 pragma Export
(Ada
, Get_RC_Offset
, "ada__tags__get_rc_offset");
221 -- This procedure is used in s-finimp to compute the deep routines
222 -- it is exported manually in order to avoid changing completely the
223 -- organization of the run time.
225 function Get_Remotely_Callable
(T
: Tag
) return Boolean;
226 -- Return the value previously set by Set_Remotely_Callable
228 function Get_Tagged_Kind
(T
: Tag
) return Tagged_Kind
;
229 -- Given a pointer to either a primary or a secondary dispatch table,
230 -- return the tagged kind of a type in the context of concurrency and
233 procedure Inherit_DT
(Old_T
: Tag
; New_T
: Tag
; Entry_Count
: Natural);
234 -- Entry point used to initialize the DT of a type knowing the tag
235 -- of the direct ancestor and the number of primitive ops that are
236 -- inherited (Entry_Count).
238 procedure Inherit_TSD
(Old_Tag
: Tag
; New_Tag
: Tag
);
239 -- Initialize the TSD of a type knowing the tag of the direct ancestor
241 function Offset_To_Top
242 (T
: Tag
) return System
.Storage_Elements
.Storage_Offset
;
243 -- Returns the current value of the offset_to_top component available in
244 -- the prologue of the dispatch table.
246 function OSD
(T
: Tag
) return Object_Specific_Data_Ptr
;
247 -- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table,
248 -- retrieve the address of the record containing the Objet Specific
252 (Obj
: System
.Address
;
253 T
: Tag
) return SSE
.Storage_Count
;
254 -- Computes the size the ancestor part of a tagged extension object whose
255 -- address is 'obj' by calling indirectly the ancestor _size function. The
256 -- ancestor is the parent of the type represented by tag T. This function
257 -- assumes that _size is always in slot one of the dispatch table.
259 pragma Export
(Ada
, Parent_Size
, "ada__tags__parent_size");
260 -- This procedure is used in s-finimp and is thus exported manually
262 procedure Register_Interface_Tag
265 Position
: Positive);
266 -- Ada 2005 (AI-251): Used to initialize the table of interfaces
267 -- implemented by a type. Required to give support to backward interface
268 -- conversions and also to IW_Membership.
270 procedure Register_Tag
(T
: Tag
);
271 -- Insert the Tag and its associated external_tag in a table for the
272 -- sake of Internal_Tag
274 procedure Set_Access_Level
(T
: Tag
; Value
: Natural);
275 -- Sets the accessibility level of the tagged type associated with T
278 procedure Set_Entry_Index
(T
: Tag
; Position
: Positive; Value
: Positive);
279 -- Set the entry index of a primitive operation in T's TSD table indexed
282 procedure Set_Expanded_Name
(T
: Tag
; Value
: System
.Address
);
283 -- Set the address of the string containing the expanded name
284 -- in the Dispatch table.
286 procedure Set_External_Tag
(T
: Tag
; Value
: System
.Address
);
287 -- Set the address of the string containing the external tag
288 -- in the Dispatch table.
290 procedure Set_Interface_Table
(T
: Tag
; Value
: System
.Address
);
291 -- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, stores the
292 -- pointer to the table of interfaces.
294 procedure Set_Num_Prim_Ops
(T
: Tag
; Value
: Natural);
295 -- Set the number of primitive operations in the dispatch table of T. This
296 -- is used for debugging purposes.
298 procedure Set_Offset_Index
302 -- Set the offset value of a primitive operation in a secondary dispatch
303 -- table denoted by T, indexed by Position.
305 procedure Set_Offset_To_Top
306 (This
: System
.Address
;
308 Offset_Value
: System
.Storage_Elements
.Storage_Offset
);
309 -- Ada 2005 (AI-251): Initialize the Offset_To_Top field in the prologue of
310 -- the dispatch table. In primary dispatch tables the value of "This" is
311 -- not required (and the compiler passes always the Null_Address value) and
312 -- the Offset_Value is always cero; in secondary dispatch tables "This"
313 -- points to the object, Interface_T is the interface for which the
314 -- secondary dispatch table is being initialized, and Offset_Value is the
315 -- distance from "This" to the object component containing the tag of the
316 -- secondary dispatch table.
318 procedure Set_OSD
(T
: Tag
; Value
: System
.Address
);
319 -- Given a pointer T to a secondary dispatch table, store the pointer to
320 -- the record containing the Object Specific Data generated by GNAT.
322 procedure Set_Prim_Op_Address
325 Value
: System
.Address
);
326 -- Given a pointer to a dispatch Table (T) and a position in the dispatch
327 -- Table put the address of the virtual function in it (used for
330 procedure Set_Prim_Op_Kind
333 Value
: Prim_Op_Kind
);
334 -- Set the kind of a primitive operation in T's TSD table indexed by
337 procedure Set_RC_Offset
(T
: Tag
; Value
: SSE
.Storage_Offset
);
338 -- Sets the Offset of the implicit record controller when the object
339 -- has controlled components. Set to O otherwise.
341 procedure Set_Remotely_Callable
(T
: Tag
; Value
: Boolean);
342 -- Set to true if the type has been declared in a context described
345 procedure Set_SSD
(T
: Tag
; Value
: System
.Address
);
346 -- Given a pointer T to a dispatch Table, stores the pointer to the record
347 -- containing the Select Specific Data generated by GNAT.
349 procedure Set_Tagged_Kind
(T
: Tag
; Value
: Tagged_Kind
);
350 -- Set the tagged kind of a type in either a primary or a secondary
351 -- dispatch table denoted by T.
353 procedure Set_TSD
(T
: Tag
; Value
: System
.Address
);
354 -- Given a pointer T to a dispatch Table, stores the address of the record
355 -- containing the Type Specific Data generated by GNAT.
357 function SSD
(T
: Tag
) return Select_Specific_Data_Ptr
;
358 -- Given a pointer T to a dispatch Table, retrieves the address of the
359 -- record containing the Select Specific Data in T's TSD.
361 function TSD
(T
: Tag
) return Type_Specific_Data_Ptr
;
362 -- Given a pointer T to a dispatch Table, retrieves the address of the
363 -- record containing the Type Specific Data generated by GNAT.
365 DT_Prologue_Size
: constant SSE
.Storage_Count
:=
366 SSE
.Storage_Count
(4 * (Standard
'Address_Size / System
.Storage_Unit
));
367 -- Size of the first part of the dispatch table
369 DT_Signature_Size
: constant SSE
.Storage_Count
:=
370 SSE
.Storage_Count
(1 * (Standard
'Address_Size / System
.Storage_Unit
));
371 -- Size of the Signature field of the dispatch table
373 DT_Tagged_Kind_Size
: constant SSE
.Storage_Count
:=
374 SSE
.Storage_Count
(1 * (Standard
'Address_Size / System
.Storage_Unit
));
375 -- Size of the Tagged_Type_Kind field of the dispatch table
377 DT_Offset_To_Top_Size
: constant SSE
.Storage_Count
:=
378 SSE
.Storage_Count
(1 * (Standard
'Address_Size / System
.Storage_Unit
));
379 -- Size of the Offset_To_Top field of the Dispatch Table
381 DT_Typeinfo_Ptr_Size
: constant SSE
.Storage_Count
:=
382 SSE
.Storage_Count
(1 * (Standard
'Address_Size / System
.Storage_Unit
));
383 -- Size of the Typeinfo_Ptr field of the Dispatch Table
385 DT_Entry_Size
: constant SSE
.Storage_Count
:=
386 SSE
.Storage_Count
(1 * (Standard
'Address_Size / System
.Storage_Unit
));
387 -- Size of each primitive operation entry in the Dispatch Table
389 TSD_Prologue_Size
: constant SSE
.Storage_Count
:=
390 SSE
.Storage_Count
(10 * (Standard
'Address_Size / System
.Storage_Unit
));
391 -- Size of the first part of the type specific data
393 TSD_Entry_Size
: constant SSE
.Storage_Count
:=
394 SSE
.Storage_Count
(1 * (Standard
'Address_Size / System
.Storage_Unit
));
395 -- Size of each ancestor tag entry in the TSD
397 type Address_Array
is array (Natural range <>) of System
.Address
;
398 pragma Suppress
(Index_Check
, On
=> Address_Array
);
399 -- The reason we suppress index checks is that in the body, objects
400 -- of this type are declared with a dummy size of 1, the actual size
401 -- depending on the number of primitive operations.
403 type Signature_Kind
is
409 for Signature_Kind
'Size use 8;
410 -- Kind of signature found in the header of the dispatch table. These
411 -- signatures are generated by the frontend and are used by the Check_XXX
412 -- routines to ensure that the kind of dispatch table managed by each of
413 -- the routines in this package is correct. This additional check is only
414 -- performed with this run-time package is compiled with assertions enabled
416 -- The signature is a sequence of two bytes. The first byte must have the
417 -- value Valid_Signature, and the second byte must have a value in the
418 -- range Primary_DT .. Abstract_Interface. The Unknown value is used by
419 -- the Check_XXX routines to indicate that the signature is wrong.
421 -- Unchecked Conversions
423 type Addr_Ptr
is access System
.Address
;
424 type Tag_Ptr
is access Tag
;
426 type Signature_Values
is
427 array (1 .. DT_Signature_Size
) of Signature_Kind
;
428 -- Type used to see the signature as a sequence of Signature_Kind values
430 function To_Addr_Ptr
is
431 new Unchecked_Conversion
(System
.Address
, Addr_Ptr
);
433 function To_Type_Specific_Data_Ptr
is
434 new Unchecked_Conversion
(System
.Address
, Type_Specific_Data_Ptr
);
436 function To_Address
is
437 new Unchecked_Conversion
(Interface_Tag
, System
.Address
);
439 function To_Address
is
440 new Unchecked_Conversion
(Tag
, System
.Address
);
442 function To_Address
is
443 new Unchecked_Conversion
(Type_Specific_Data_Ptr
, System
.Address
);
445 function To_Interface_Data_Ptr
is
446 new Unchecked_Conversion
(System
.Address
, Interface_Data_Ptr
);
448 function To_Object_Specific_Data_Ptr
is
449 new Unchecked_Conversion
(System
.Address
, Object_Specific_Data_Ptr
);
451 function To_Select_Specific_Data_Ptr
is
452 new Unchecked_Conversion
(System
.Address
, Select_Specific_Data_Ptr
);
454 function To_Signature_Values
is
455 new Unchecked_Conversion
(System
.Storage_Elements
.Storage_Offset
,
458 function To_Tag_Ptr
is
459 new Unchecked_Conversion
(System
.Address
, Tag_Ptr
);
461 function To_Tagged_Kind_Ptr
is
462 new Unchecked_Conversion
(System
.Address
, Tagged_Kind_Ptr
);
464 -- Primitive dispatching operations are always inlined, to facilitate
465 -- use in a minimal/no run-time environment for high integrity use.
467 pragma Inline_Always
(CW_Membership
);
468 pragma Inline_Always
(Displace
);
469 pragma Inline_Always
(IW_Membership
);
470 pragma Inline_Always
(Get_Access_Level
);
471 pragma Inline_Always
(Get_Entry_Index
);
472 pragma Inline_Always
(Get_Offset_Index
);
473 pragma Inline_Always
(Get_Prim_Op_Address
);
474 pragma Inline_Always
(Get_Prim_Op_Kind
);
475 pragma Inline_Always
(Get_RC_Offset
);
476 pragma Inline_Always
(Get_Remotely_Callable
);
477 pragma Inline_Always
(Get_Tagged_Kind
);
478 pragma Inline_Always
(Inherit_DT
);
479 pragma Inline_Always
(Inherit_TSD
);
480 pragma Inline_Always
(OSD
);
481 pragma Inline_Always
(Register_Interface_Tag
);
482 pragma Inline_Always
(Register_Tag
);
483 pragma Inline_Always
(Set_Access_Level
);
484 pragma Inline_Always
(Set_Entry_Index
);
485 pragma Inline_Always
(Set_Expanded_Name
);
486 pragma Inline_Always
(Set_External_Tag
);
487 pragma Inline_Always
(Set_Interface_Table
);
488 pragma Inline_Always
(Set_Num_Prim_Ops
);
489 pragma Inline_Always
(Set_Offset_Index
);
490 pragma Inline_Always
(Set_Offset_To_Top
);
491 pragma Inline_Always
(Set_Prim_Op_Address
);
492 pragma Inline_Always
(Set_Prim_Op_Kind
);
493 pragma Inline_Always
(Set_RC_Offset
);
494 pragma Inline_Always
(Set_Remotely_Callable
);
495 pragma Inline_Always
(Set_OSD
);
496 pragma Inline_Always
(Set_SSD
);
497 pragma Inline_Always
(Set_TSD
);
498 pragma Inline_Always
(Set_Tagged_Kind
);
499 pragma Inline_Always
(SSD
);
500 pragma Inline_Always
(TSD
);