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, 59 Temple Place - Suite 330, Boston, --
24 -- MA 02111-1307, 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 (Tags);
44 -- In accordance with Ada 2005 AI-362
46 pragma Elaborate_Body;
47 -- We need a dummy body to solve bootstrap path issues (why ???)
51 No_Tag : constant Tag;
53 function Expanded_Name (T : Tag) return String;
55 function External_Tag (T : Tag) return String;
57 function Internal_Tag (External : String) return Tag;
59 function Descendant_Tag (External : String; Ancestor : Tag) return Tag;
61 function Is_Descendant_At_Same_Level
63 Ancestor : Tag) return Boolean;
65 function Parent_Tag (T : Tag) return Tag;
67 Tag_Error : exception;
71 ---------------------------------------------------------------
72 -- Abstract Procedural Interface For The GNAT Dispatch Table --
73 ---------------------------------------------------------------
75 -- GNAT's Dispatch Table format is customizable in order to match the
76 -- format used in another language. GNAT supports programs that use
77 -- two different dispatch table formats at the same time: the native
78 -- format that supports Ada 95 tagged types and which is described in
79 -- Ada.Tags, and a foreign format for types that are imported from some
80 -- other language (typically C++) which is described in Interfaces.CPP.
81 -- The runtime information kept for each tagged type is separated into
82 -- two objects: the Dispatch Table and the Type Specific Data record.
83 -- These two objects are allocated statically using the constants:
85 -- DT Size = DT_Prologue_Size + Nb_Prim * DT_Entry_Size
86 -- TSD Size = TSD_Prologue_Size + (1 + Idepth) * TSD_Entry_Size
88 -- where Nb_prim is the number of primitive operations of the given
89 -- type and Idepth its inheritance depth.
91 -- The compiler generates calls to the following SET routines to
92 -- initialize those structures and uses the GET functions to
93 -- retreive the information when needed
96 type Tag is access all Dispatch_Table;
97 type Interface_Tag is access all Dispatch_Table;
99 No_Tag : constant Tag := null;
101 type Type_Specific_Data;
102 type Type_Specific_Data_Ptr is access all Type_Specific_Data;
104 package SSE renames System.Storage_Elements;
106 function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
107 -- Given the tag of an object and the tag associated to a type, return
108 -- true if Obj is in Typ'Class.
110 function IW_Membership
111 (This : System.Address;
112 Iface_Tag : Tag) return Boolean;
113 -- Ada 2005 (AI-251): Given the tag of an object and the tag associated
114 -- with an interface, return true if Obj is in Iface'Class.
116 function Get_Access_Level (T : Tag) return Natural;
117 -- Given the tag associated with a type, returns the accessibility level
120 function Get_External_Tag (T : Tag) return System.Address;
121 -- Retrieve the address of a null terminated string containing
124 function Get_Prim_Op_Address
126 Position : Positive) return System.Address;
127 -- Given a pointer to a dispatch Table (T) and a position in the DT
128 -- this function returns the address of the virtual function stored
129 -- in it (used for dispatching calls)
131 function Get_RC_Offset (T : Tag) return SSE.Storage_Offset;
132 -- Return the Offset of the implicit record controller when the object
133 -- has controlled components. O otherwise.
135 pragma Export (Ada, Get_RC_Offset, "ada__tags__get_rc_offset");
136 -- This procedure is used in s-finimp to compute the deep routines
137 -- it is exported manually in order to avoid changing completely the
138 -- organization of the run time.
140 function Get_Remotely_Callable (T : Tag) return Boolean;
141 -- Return the value previously set by Set_Remotely_Callable
146 Entry_Count : Natural);
147 -- Entry point used to initialize the DT of a type knowing the tag
148 -- of the direct ancestor and the number of primitive ops that are
149 -- inherited (Entry_Count).
151 procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag);
152 -- Initialize the TSD of a type knowing the tag of the direct ancestor
155 (Obj : System.Address;
156 T : Tag) return SSE.Storage_Count;
157 -- Computes the size the ancestor part of a tagged extension object
158 -- whose address is 'obj' by calling the indirectly _size function of
159 -- the ancestor. The ancestor is the parent of the type represented by
160 -- tag T. This function assumes that _size is always in slot 1 of
161 -- the dispatch table.
163 pragma Export (Ada, Parent_Size, "ada__tags__parent_size");
164 -- This procedure is used in s-finimp and is thus exported manually
166 procedure Register_Interface_Tag
169 -- Ada 2005 (AI-251): Used to initialize the table of interfaces
170 -- implemented by a type. Required to give support to IW_Membership.
172 procedure Register_Tag (T : Tag);
173 -- Insert the Tag and its associated external_tag in a table for the
174 -- sake of Internal_Tag
176 procedure Set_Offset_To_Top
178 Value : System.Storage_Elements.Storage_Offset);
179 -- Ada 2005 (AI-251): Initialize the Offset_To_Top field in the prologue of
180 -- the dispatch table. In primary dispatch tables the value of this field
181 -- is always 0; in secondary dispatch tables this is the offset to the base
182 -- of the enclosing type.
184 procedure Set_Prim_Op_Address
187 Value : System.Address);
188 -- Given a pointer to a dispatch Table (T) and a position in the
189 -- dispatch Table put the address of the virtual function in it
190 -- (used for overriding)
192 procedure Set_TSD (T : Tag; Value : System.Address);
193 -- Given a pointer T to a dispatch Table, stores the address of the record
194 -- containing the Type Specific Data generated by GNAT
196 procedure Set_Access_Level (T : Tag; Value : Natural);
197 -- Sets the accessibility level of the tagged type associated with T
200 procedure Set_Expanded_Name (T : Tag; Value : System.Address);
201 -- Set the address of the string containing the expanded name
202 -- in the Dispatch table
204 procedure Set_External_Tag (T : Tag; Value : System.Address);
205 -- Set the address of the string containing the external tag
206 -- in the Dispatch table
208 procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset);
209 -- Sets the Offset of the implicit record controller when the object
210 -- has controlled components. Set to O otherwise.
212 procedure Set_Remotely_Callable (T : Tag; Value : Boolean);
213 -- Set to true if the type has been declared in a context described
216 function TSD (T : Tag) return Type_Specific_Data_Ptr;
217 -- Given a pointer T to a dispatch Table, retreives the address of the
218 -- record containing the Type Specific Data generated by GNAT
220 DT_Prologue_Size : constant SSE.Storage_Count :=
222 (2 * (Standard'Address_Size / System.Storage_Unit));
223 -- Size of the first part of the dispatch table
225 DT_Offset_To_Top_Size : constant SSE.Storage_Count :=
227 (Standard'Address_Size / System.Storage_Unit);
228 -- Size of the Offset_To_Top field of the Dispatch Table
230 DT_Typeinfo_Ptr_Size : constant SSE.Storage_Count :=
232 (Standard'Address_Size / System.Storage_Unit);
233 -- Size of the Typeinfo_Ptr field of the Dispatch Table
235 DT_Entry_Size : constant SSE.Storage_Count :=
237 (1 * (Standard'Address_Size / System.Storage_Unit));
238 -- Size of each primitive operation entry in the Dispatch Table
240 TSD_Prologue_Size : constant SSE.Storage_Count :=
242 (8 * (Standard'Address_Size / System.Storage_Unit));
243 -- Size of the first part of the type specific data
245 TSD_Entry_Size : constant SSE.Storage_Count :=
246 SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
247 -- Size of each ancestor tag entry in the TSD
249 type Address_Array is array (Natural range <>) of System.Address;
250 pragma Suppress (Index_Check, On => Address_Array);
251 -- The reason we suppress index checks is that in the body, objects
252 -- of this type are declared with a dummy size of 1, the actual size
253 -- depending on the number of primitive operations.
255 -- Unchecked Conversions for Tag and TSD
257 function To_Type_Specific_Data_Ptr is
258 new Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
260 function To_Address is
261 new Unchecked_Conversion (Type_Specific_Data_Ptr, System.Address);
263 function To_Address is
264 new Unchecked_Conversion (Tag, System.Address);
266 type Addr_Ptr is access System.Address;
267 type Tag_Ptr is access Tag;
269 function To_Addr_Ptr is
270 new Unchecked_Conversion (System.Address, Addr_Ptr);
272 function To_Tag_Ptr is
273 new Unchecked_Conversion (System.Address, Tag_Ptr);
275 -- Primitive dispatching operations are always inlined, to facilitate
276 -- use in a minimal/no run-time environment for high integrity use.
278 pragma Inline_Always (CW_Membership);
279 pragma Inline_Always (IW_Membership);
280 pragma Inline_Always (Get_Access_Level);
281 pragma Inline_Always (Get_Prim_Op_Address);
282 pragma Inline_Always (Get_RC_Offset);
283 pragma Inline_Always (Get_Remotely_Callable);
284 pragma Inline_Always (Inherit_DT);
285 pragma Inline_Always (Inherit_TSD);
286 pragma Inline_Always (Register_Interface_Tag);
287 pragma Inline_Always (Register_Tag);
288 pragma Inline_Always (Set_Access_Level);
289 pragma Inline_Always (Set_Expanded_Name);
290 pragma Inline_Always (Set_External_Tag);
291 pragma Inline_Always (Set_Offset_To_Top);
292 pragma Inline_Always (Set_Prim_Op_Address);
293 pragma Inline_Always (Set_RC_Offset);
294 pragma Inline_Always (Set_Remotely_Callable);
295 pragma Inline_Always (Set_TSD);
296 pragma Inline_Always (TSD);