* c-common.c (get_priority): Add check for
[official-gcc.git] / gcc / ada / a-tags.ads
blob24fedab7ff8b64cfb057ae1b9532459e39ff88e9
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-2006, 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;
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
64 (External : String;
65 Ancestor : Tag) return Tag;
66 pragma Ada_05 (Descendant_Tag);
68 function Is_Descendant_At_Same_Level
69 (Descendant : Tag;
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;
83 private
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.
111 type Dispatch_Table;
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.
142 type Prim_Op_Kind is
143 (POK_Function,
144 POK_Procedure,
145 POK_Protected_Entry,
146 POK_Protected_Function,
147 POK_Protected_Procedure,
148 POK_Task_Entry,
149 POK_Task_Function,
150 POK_Task_Procedure);
152 -- Tagged type kinds with respect to concurrency and limitedness
154 type Tagged_Kind is
155 (TK_Abstract_Limited_Tagged,
156 TK_Abstract_Tagged,
157 TK_Limited_Tagged,
158 TK_Protected,
159 TK_Tagged,
160 TK_Task);
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
169 (Unknown,
170 Valid_Signature,
171 Primary_DT,
172 Secondary_DT,
173 Abstract_Interface);
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
202 -- begin
203 -- return O in T'Class.
204 -- end Test;
206 function Displace (This : System.Address; T : Tag) return System.Address;
207 -- (Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch
208 -- table of T.
210 function Get_Access_Level (T : Tag) return Natural;
211 -- Given the tag associated with a type, returns the accessibility level
212 -- of the type.
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
223 (T : Tag;
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
230 (T : Tag;
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
237 (T : Tag;
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
244 (T : Tag;
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
264 -- limitedness.
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
289 -- Data table.
291 function Parent_Size
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
303 (T : Tag;
304 Interface_T : 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
316 -- in its TSD.
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
320 -- by Position.
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
339 (T : Tag;
340 Position : Positive;
341 Value : Positive);
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;
347 Interface_T : Tag;
348 Is_Static : Boolean;
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
365 (T : Tag;
366 Position : Positive;
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
373 (T : Tag;
374 Position : Positive;
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
378 -- overriding).
380 procedure Set_Prim_Op_Kind
381 (T : Tag;
382 Position : Positive;
383 Value : Prim_Op_Kind);
384 -- Set the kind of a primitive operation in T's TSD table indexed by
385 -- Position.
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
393 -- in E.4 (18).
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 :=
419 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 :=
426 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 :=
435 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 :=
441 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 :=
447 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));
453 -- Size of each tag
455 TSD_Prologue_Size : constant SSE.Storage_Count :=
456 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 :=
462 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,
509 Signature_Values);
511 function To_Signature_Values_Ptr is
512 new Unchecked_Conversion (System.Address,
513 Signature_Values_Ptr);
515 function To_Tag is
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);
565 end Ada.Tags;