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