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
(External
: String; Ancestor
: Tag
) return Tag
;
58 function Is_Descendant_At_Same_Level
60 Ancestor
: Tag
) return Boolean;
62 function Parent_Tag
(T
: Tag
) return Tag
;
64 Tag_Error
: exception;
68 ---------------------------------------------------------------
69 -- Abstract Procedural Interface For The GNAT Dispatch Table --
70 ---------------------------------------------------------------
72 -- GNAT's Dispatch Table format is customizable in order to match the
73 -- format used in another language. GNAT supports programs that use
74 -- two different dispatch table formats at the same time: the native
75 -- format that supports Ada 95 tagged types and which is described in
76 -- Ada.Tags, and a foreign format for types that are imported from some
77 -- other language (typically C++) which is described in Interfaces.CPP.
78 -- The runtime information kept for each tagged type is separated into
79 -- two objects: the Dispatch Table and the Type Specific Data record.
80 -- These two objects are allocated statically using the constants:
82 -- DT Size = DT_Prologue_Size + Nb_Prim * DT_Entry_Size
83 -- TSD Size = TSD_Prologue_Size + (1 + Idepth) * TSD_Entry_Size
85 -- where Nb_prim is the number of primitive operations of the given
86 -- type and Idepth its inheritance depth.
88 -- The compiler generates calls to the following SET routines to
89 -- initialize those structures and uses the GET functions to
90 -- retreive the information when needed
93 type Tag
is access all Dispatch_Table
;
94 type Interface_Tag
is access all Dispatch_Table
;
96 No_Tag
: constant Tag
:= null;
98 type Type_Specific_Data
;
99 type Type_Specific_Data_Ptr
is access all Type_Specific_Data
;
101 -- Primitive operation kinds. These values differentiate the kinds of
102 -- callable entities stored in the dispatch table. Certain kinds may
103 -- not be used, but are added for completeness.
109 POK_Protected_Function
,
110 POK_Protected_Procedure
,
114 -- Number of predefined primitive operations added by the Expander
115 -- for a tagged type. It is utilized for indexing in the two auxiliary
116 -- tables used for dispatching asynchronous, conditional and timed
117 -- selects. In order to be space efficien, indexing is performed by
118 -- subtracting this constant value from the provided position in the
120 -- This value is mirrored from Exp_Disp.ads.
122 Default_Prim_Op_Count
: constant Positive := 14;
124 package SSE
renames System
.Storage_Elements
;
126 function CW_Membership
(Obj_Tag
: Tag
; Typ_Tag
: Tag
) return Boolean;
127 -- Given the tag of an object and the tag associated to a type, return
128 -- true if Obj is in Typ'Class.
130 function IW_Membership
131 (This
: System
.Address
;
132 T
: Tag
) return Boolean;
133 -- Ada 2005 (AI-251): General routine that checks if a given object
134 -- implements a tagged type. Its common usage is to check if Obj is in
135 -- Iface'Class, but it is also used to check if a class-wide interface
136 -- implements a given type (Iface_CW_Typ in T'Class). For example:
138 -- type I is interface;
139 -- type T is tagged ...
141 -- function Test (O : in I'Class) is
143 -- return O in T'Class.
146 function Get_Access_Level
(T
: Tag
) return Natural;
147 -- Given the tag associated with a type, returns the accessibility level
150 function Get_Entry_Index
152 Position
: Positive) return Positive;
153 -- Return a primitive operation's entry index (if entry) given a dispatch
154 -- table T and a position of a primitive operation in T.
156 function Get_External_Tag
(T
: Tag
) return System
.Address
;
157 -- Retrieve the address of a null terminated string containing
160 function Get_Prim_Op_Address
162 Position
: Positive) return System
.Address
;
163 -- Given a pointer to a dispatch table (T) and a position in the DT
164 -- this function returns the address of the virtual function stored
165 -- in it (used for dispatching calls)
167 function Get_Prim_Op_Kind
169 Position
: Positive) return Prim_Op_Kind
;
170 -- Return a primitive operation's kind given a dispatch table T and a
171 -- position of a primitive operation in T.
173 function Get_RC_Offset
(T
: Tag
) return SSE
.Storage_Offset
;
174 -- Return the Offset of the implicit record controller when the object
175 -- has controlled components. O otherwise.
177 pragma Export
(Ada
, Get_RC_Offset
, "ada__tags__get_rc_offset");
178 -- This procedure is used in s-finimp to compute the deep routines
179 -- it is exported manually in order to avoid changing completely the
180 -- organization of the run time.
182 function Get_Remotely_Callable
(T
: Tag
) return Boolean;
183 -- Return the value previously set by Set_Remotely_Callable
188 Entry_Count
: Natural);
189 -- Entry point used to initialize the DT of a type knowing the tag
190 -- of the direct ancestor and the number of primitive ops that are
191 -- inherited (Entry_Count).
193 procedure Inherit_TSD
(Old_Tag
: Tag
; New_Tag
: Tag
);
194 -- Initialize the TSD of a type knowing the tag of the direct ancestor
197 (Obj
: System
.Address
;
198 T
: Tag
) return SSE
.Storage_Count
;
199 -- Computes the size the ancestor part of a tagged extension object
200 -- whose address is 'obj' by calling the indirectly _size function of
201 -- the ancestor. The ancestor is the parent of the type represented by
202 -- tag T. This function assumes that _size is always in slot 1 of
203 -- the dispatch table.
205 pragma Export
(Ada
, Parent_Size
, "ada__tags__parent_size");
206 -- This procedure is used in s-finimp and is thus exported manually
208 procedure Register_Interface_Tag
211 -- Ada 2005 (AI-251): Used to initialize the table of interfaces
212 -- implemented by a type. Required to give support to IW_Membership.
214 procedure Register_Tag
(T
: Tag
);
215 -- Insert the Tag and its associated external_tag in a table for the
216 -- sake of Internal_Tag
218 procedure Set_Entry_Index
222 -- Set the entry index of a primitive operation in T's TSD table indexed
225 procedure Set_Offset_To_Top
227 Value
: System
.Storage_Elements
.Storage_Offset
);
228 -- Ada 2005 (AI-251): Initialize the Offset_To_Top field in the prologue of
229 -- the dispatch table. In primary dispatch tables the value of this field
230 -- is always 0; in secondary dispatch tables this is the offset to the base
231 -- of the enclosing type.
233 procedure Set_Prim_Op_Address
236 Value
: System
.Address
);
237 -- Given a pointer to a dispatch Table (T) and a position in the dispatch
238 -- Table put the address of the virtual function in it (used for
241 procedure Set_Prim_Op_Kind
244 Value
: Prim_Op_Kind
);
245 -- Set the kind of a primitive operation in T's TSD table indexed by
248 procedure Set_TSD
(T
: Tag
; Value
: System
.Address
);
249 -- Given a pointer T to a dispatch Table, stores the address of the record
250 -- containing the Type Specific Data generated by GNAT.
252 procedure Set_Access_Level
(T
: Tag
; Value
: Natural);
253 -- Sets the accessibility level of the tagged type associated with T
256 procedure Set_Expanded_Name
(T
: Tag
; Value
: System
.Address
);
257 -- Set the address of the string containing the expanded name
258 -- in the Dispatch table.
260 procedure Set_External_Tag
(T
: Tag
; Value
: System
.Address
);
261 -- Set the address of the string containing the external tag
262 -- in the Dispatch table.
264 procedure Set_RC_Offset
(T
: Tag
; Value
: SSE
.Storage_Offset
);
265 -- Sets the Offset of the implicit record controller when the object
266 -- has controlled components. Set to O otherwise.
268 procedure Set_Remotely_Callable
(T
: Tag
; Value
: Boolean);
269 -- Set to true if the type has been declared in a context described
272 function TSD
(T
: Tag
) return Type_Specific_Data_Ptr
;
273 -- Given a pointer T to a dispatch Table, retreives the address of the
274 -- record containing the Type Specific Data generated by GNAT
276 DT_Prologue_Size
: constant SSE
.Storage_Count
:=
278 (2 * (Standard
'Address_Size / System
.Storage_Unit
));
279 -- Size of the first part of the dispatch table
281 DT_Offset_To_Top_Size
: constant SSE
.Storage_Count
:=
283 (Standard
'Address_Size / System
.Storage_Unit
);
284 -- Size of the Offset_To_Top field of the Dispatch Table
286 DT_Typeinfo_Ptr_Size
: constant SSE
.Storage_Count
:=
288 (Standard
'Address_Size / System
.Storage_Unit
);
289 -- Size of the Typeinfo_Ptr field of the Dispatch Table
291 DT_Entry_Size
: constant SSE
.Storage_Count
:=
293 (1 * (Standard
'Address_Size / System
.Storage_Unit
));
294 -- Size of each primitive operation entry in the Dispatch Table
296 TSD_Prologue_Size
: constant SSE
.Storage_Count
:=
298 (8 * (Standard
'Address_Size / System
.Storage_Unit
));
299 -- Size of the first part of the type specific data
301 TSD_Entry_Size
: constant SSE
.Storage_Count
:=
302 SSE
.Storage_Count
(1 * (Standard
'Address_Size / System
.Storage_Unit
));
303 -- Size of each ancestor tag entry in the TSD
305 type Address_Array
is array (Natural range <>) of System
.Address
;
306 pragma Suppress
(Index_Check
, On
=> Address_Array
);
307 -- The reason we suppress index checks is that in the body, objects
308 -- of this type are declared with a dummy size of 1, the actual size
309 -- depending on the number of primitive operations.
311 -- Unchecked Conversions for Tag and TSD
313 function To_Type_Specific_Data_Ptr
is
314 new Unchecked_Conversion
(System
.Address
, Type_Specific_Data_Ptr
);
316 function To_Address
is
317 new Unchecked_Conversion
(Type_Specific_Data_Ptr
, System
.Address
);
319 function To_Address
is
320 new Unchecked_Conversion
(Tag
, System
.Address
);
322 type Addr_Ptr
is access System
.Address
;
323 type Tag_Ptr
is access Tag
;
325 function To_Addr_Ptr
is
326 new Unchecked_Conversion
(System
.Address
, Addr_Ptr
);
328 function To_Tag_Ptr
is
329 new Unchecked_Conversion
(System
.Address
, Tag_Ptr
);
331 -- Primitive dispatching operations are always inlined, to facilitate
332 -- use in a minimal/no run-time environment for high integrity use.
334 pragma Inline_Always
(CW_Membership
);
335 pragma Inline_Always
(IW_Membership
);
336 pragma Inline_Always
(Get_Access_Level
);
337 pragma Inline_Always
(Get_Prim_Op_Address
);
338 pragma Inline_Always
(Get_RC_Offset
);
339 pragma Inline_Always
(Get_Remotely_Callable
);
340 pragma Inline_Always
(Inherit_DT
);
341 pragma Inline_Always
(Inherit_TSD
);
342 pragma Inline_Always
(Register_Interface_Tag
);
343 pragma Inline_Always
(Register_Tag
);
344 pragma Inline_Always
(Set_Access_Level
);
345 pragma Inline_Always
(Set_Expanded_Name
);
346 pragma Inline_Always
(Set_External_Tag
);
347 pragma Inline_Always
(Set_Offset_To_Top
);
348 pragma Inline_Always
(Set_Prim_Op_Address
);
349 pragma Inline_Always
(Set_RC_Offset
);
350 pragma Inline_Always
(Set_Remotely_Callable
);
351 pragma Inline_Always
(Set_TSD
);
352 pragma Inline_Always
(TSD
);