1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
9 -- $Revision: 1.23 $ --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
13 -- This specification is derived from the Ada Reference Manual for use with --
14 -- GNAT. The copyright notice above, and the license provisions that follow --
15 -- apply solely to the contents of the part following the private keyword. --
17 -- GNAT is free software; you can redistribute it and/or modify it under --
18 -- terms of the GNU General Public License as published by the Free Soft- --
19 -- ware Foundation; either version 2, or (at your option) any later ver- --
20 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
21 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
22 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
23 -- for more details. You should have received a copy of the GNU General --
24 -- Public License distributed with GNAT; see file COPYING. If not, write --
25 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
26 -- MA 02111-1307, USA. --
28 -- As a special exception, if other files instantiate generics from this --
29 -- unit, or you link this unit with other files to produce an executable, --
30 -- this unit does not by itself cause the resulting executable to be --
31 -- covered by the GNU General Public License. This exception does not --
32 -- however invalidate any other reasons why the executable file might be --
33 -- covered by the GNU Public License. --
35 -- GNAT was originally developed by the GNAT team at New York University. --
36 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
38 ------------------------------------------------------------------------------
41 with System.Storage_Elements;
45 pragma Elaborate_Body;
49 function Expanded_Name (T : Tag) return String;
51 function External_Tag (T : Tag) return String;
53 function Internal_Tag (External : String) return Tag;
55 Tag_Error : exception;
59 ----------------------------------------------------------------
60 -- Abstract procedural interface for the GNAT dispatch table --
61 ----------------------------------------------------------------
63 -- GNAT's Dispatch Table format is customizable in order to match the
64 -- format used in another langauge. GNAT supports programs that use
65 -- two different dispatch table format at the same time: the native
66 -- format that supports Ada 95 tagged types and which is described in
67 -- Ada.Tags and a foreign format for types that are imported from some
68 -- other language (typically C++) which is described in interfaces.cpp.
69 -- The runtime information kept for each tagged type is separated into
70 -- two objects: the Dispatch Table and the Type Specific Data record.
71 -- These two objects are allocated statically using the constants:
73 -- DT Size = DT_Prologue_Size + Nb_Prim * DT_Entry_Size
74 -- TSD Size = TSD_Prologue_Size + (1 + Idepth) * TSD_Entry_Size
76 -- where Nb_prim is the number of primitive operations of the given
77 -- type and Idepth its inheritance depth.
79 -- The compiler generates calls to the following SET routines to
80 -- initialize those structures and uses the GET functions to
81 -- retreive the information when needed
83 package S renames System;
84 package SSE renames System.Storage_Elements;
86 function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
87 -- Given the tag of an object and the tag associated to a type, return
88 -- true if Obj is in Typ'Class.
90 function Get_Expanded_Name (T : Tag) return S.Address;
91 -- Retrieve the address of a null terminated string containing
94 function Get_External_Tag (T : Tag) return S.Address;
95 -- Retrieve the address of a null terminated string containing
98 function Get_Prim_Op_Address
102 -- Given a pointer to a dispatch Table (T) and a position in the DT
103 -- this function returns the address of the virtual function stored
104 -- in it (used for dispatching calls)
106 function Get_Inheritance_Depth (T : Tag) return Natural;
107 -- Given a pointer to a dispatch Table, retrieves the value representing
108 -- the depth in the inheritance tree (used for membership).
110 function Get_RC_Offset (T : Tag) return SSE.Storage_Offset;
111 -- Return the Offset of the implicit record controller when the object
112 -- has controlled components. O otherwise.
114 pragma Export (Ada, Get_RC_Offset, "ada__tags__get_rc_offset");
115 -- This procedure is used in s-finimp to compute the deep routines
116 -- it is exported manually in order to avoid changing completely the
117 -- organization of the run time.
119 function Get_Remotely_Callable (T : Tag) return Boolean;
120 -- Return the value previously set by Set_Remotely_Callable
122 function Get_TSD (T : Tag) return S.Address;
123 -- Given a pointer T to a dispatch Table, retreives the address of the
124 -- record containing the Type Specific Data generated by GNAT
129 Entry_Count : Natural);
130 -- Entry point used to initialize the DT of a type knowing the tag
131 -- of the direct ancestor and the number of primitive ops that are
132 -- inherited (Entry_Count).
134 procedure Inherit_TSD (Old_TSD : S.Address; New_Tag : Tag);
135 -- Entry point used to initialize the TSD of a type knowing the
136 -- TSD of the direct ancestor.
138 function Parent_Size (Obj : S.Address) return SSE.Storage_Count;
139 -- Computes the size of field _Parent of a tagged extension object
140 -- whose address is 'obj' by calling the indirectly _size function of
141 -- the parent. This function assumes that _size is always in slot 1 of
142 -- the dispatch table.
144 pragma Export (Ada, Parent_Size, "ada__tags__parent_size");
145 -- This procedure is used in s-finimp and is thus exported manually
147 procedure Register_Tag (T : Tag);
148 -- Insert the Tag and its associated external_tag in a table for the
149 -- sake of Internal_Tag
151 procedure Set_Inheritance_Depth
154 -- Given a pointer to a dispatch Table, stores the value representing
155 -- the depth in the inheritance tree (the second parameter). Used during
156 -- elaboration of the tagged type.
158 procedure Set_Prim_Op_Address
162 -- Given a pointer to a dispatch Table (T) and a position in the
163 -- dispatch Table put the address of the virtual function in it
164 -- (used for overriding)
166 procedure Set_TSD (T : Tag; Value : S.Address);
167 -- Given a pointer T to a dispatch Table, stores the address of the record
168 -- containing the Type Specific Data generated by GNAT
170 procedure Set_Expanded_Name (T : Tag; Value : S.Address);
171 -- Set the address of the string containing the expanded name
172 -- in the Dispatch table
174 procedure Set_External_Tag (T : Tag; Value : S.Address);
175 -- Set the address of the string containing the external tag
176 -- in the Dispatch table
178 procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset);
179 -- Sets the Offset of the implicit record controller when the object
180 -- has controlled components. Set to O otherwise.
182 procedure Set_Remotely_Callable (T : Tag; Value : Boolean);
183 -- Set to true if the type has been declared in a context described
186 DT_Prologue_Size : constant SSE.Storage_Count :=
188 (Standard'Address_Size / S.Storage_Unit);
189 -- Size of the first part of the dispatch table
191 DT_Entry_Size : constant SSE.Storage_Count :=
193 (Standard'Address_Size / S.Storage_Unit);
194 -- Size of each primitive operation entry in the Dispatch Table.
196 TSD_Prologue_Size : constant SSE.Storage_Count :=
198 (6 * Standard'Address_Size / S.Storage_Unit);
199 -- Size of the first part of the type specific data
201 TSD_Entry_Size : constant SSE.Storage_Count :=
202 SSE.Storage_Count (Standard'Address_Size / S.Storage_Unit);
203 -- Size of each ancestor tag entry in the TSD
205 type Address_Array is array (Natural range <>) of S.Address;
208 type Tag is access all Dispatch_Table;
210 type Type_Specific_Data;
211 type Type_Specific_Data_Ptr is access all Type_Specific_Data;
213 pragma Inline_Always (CW_Membership);
214 pragma Inline_Always (Get_Expanded_Name);
215 pragma Inline_Always (Get_Inheritance_Depth);
216 pragma Inline_Always (Get_Prim_Op_Address);
217 pragma Inline_Always (Get_RC_Offset);
218 pragma Inline_Always (Get_Remotely_Callable);
219 pragma Inline_Always (Get_TSD);
220 pragma Inline_Always (Inherit_DT);
221 pragma Inline_Always (Inherit_TSD);
222 pragma Inline_Always (Register_Tag);
223 pragma Inline_Always (Set_Expanded_Name);
224 pragma Inline_Always (Set_External_Tag);
225 pragma Inline_Always (Set_Inheritance_Depth);
226 pragma Inline_Always (Set_Prim_Op_Address);
227 pragma Inline_Always (Set_RC_Offset);
228 pragma Inline_Always (Set_Remotely_Callable);
229 pragma Inline_Always (Set_TSD);