PR c++/29733
[official-gcc.git] / gcc / ada / a-tags.ads
blobbb69544a9d3b6c384fb2ff4c470722147b00300c
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- A D A . T A G S --
6 -- --
7 -- S p e c --
8 -- --
9 -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
10 -- --
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. --
14 -- --
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. --
25 -- --
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. --
32 -- --
33 -- GNAT was originally developed by the GNAT team at New York University. --
34 -- Extensive contributions were provided by Ada Core Technologies Inc. --
35 -- --
36 ------------------------------------------------------------------------------
38 with System;
39 with System.Storage_Elements;
40 with Unchecked_Conversion;
42 package Ada.Tags is
43 pragma Preelaborate_05;
44 -- In accordance with Ada 2005 AI-362
46 type Tag is private;
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
57 (External : String;
58 Ancestor : Tag) return Tag;
59 pragma Ada_05 (Descendant_Tag);
61 function Is_Descendant_At_Same_Level
62 (Descendant : Tag;
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);
77 private
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.
105 type Dispatch_Table;
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.
136 type Prim_Op_Kind is
137 (POK_Function,
138 POK_Procedure,
139 POK_Protected_Entry,
140 POK_Protected_Function,
141 POK_Protected_Procedure,
142 POK_Task_Entry,
143 POK_Task_Function,
144 POK_Task_Procedure);
146 -- Tagged type kinds with respect to concurrency and limitedness
148 type Tagged_Kind is
149 (TK_Abstract_Limited_Tagged,
150 TK_Abstract_Tagged,
151 TK_Limited_Tagged,
152 TK_Protected,
153 TK_Tagged,
154 TK_Task);
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
163 (Unknown,
164 Valid_Signature,
165 Primary_DT,
166 Secondary_DT,
167 Abstract_Interface);
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
196 -- begin
197 -- return O in T'Class.
198 -- end Test;
200 function Displace (This : System.Address; T : Tag) return System.Address;
201 -- (Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch
202 -- table of T.
204 function Get_Access_Level (T : Tag) return Natural;
205 -- Given the tag associated with a type, returns the accessibility level
206 -- of the type.
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
217 (T : Tag;
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
224 (T : Tag;
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
231 (T : Tag;
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
238 (T : Tag;
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
258 -- limitedness.
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
278 -- Data table.
280 function Parent_Size
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
292 (T : Tag;
293 Interface_T : 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
305 -- in its TSD.
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
309 -- by Position.
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
328 (T : Tag;
329 Position : Positive;
330 Value : Positive);
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;
336 Interface_T : Tag;
337 Is_Static : Boolean;
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
354 (T : Tag;
355 Position : Positive;
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
362 (T : Tag;
363 Position : Positive;
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
367 -- overriding).
369 procedure Set_Prim_Op_Kind
370 (T : Tag;
371 Position : Positive;
372 Value : Prim_Op_Kind);
373 -- Set the kind of a primitive operation in T's TSD table indexed by
374 -- Position.
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
382 -- in E.4 (18).
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 :=
408 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 :=
415 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 :=
424 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 :=
430 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 :=
436 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));
442 -- Size of each tag
444 TSD_Prologue_Size : constant SSE.Storage_Count :=
445 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 :=
451 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,
498 Signature_Values);
500 function To_Signature_Values_Ptr is
501 new Unchecked_Conversion (System.Address,
502 Signature_Values_Ptr);
504 function To_Tag is
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);
554 end Ada.Tags;