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
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316 | ------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . T A G S --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2023, 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 3, 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. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the HI-E version of this file. It provides full object oriented
-- semantics (including dynamic dispatching and support for abstract
-- interface types), assuming that tagged types are declared at the library
-- level. Some functionality has been removed in order to simplify this
-- run-time unit. Compared to the full version of this package, the following
-- subprograms have been removed:
-- Internal_Tag, Register_Tag, Descendant_Tag, Is_Descendant_At_Same_Level:
-- These subprograms are used for cross-referencing the external and
-- internal representation of tags. The implementation of these routines
-- was considered neither simple nor esential for this restricted run-time,
-- and hence these functions were removed.
-- Get_Entry_Index, Get_Offset_Index, Get_Prim_Op_Kind, Get_Tagged_Kind,
-- SSD, Set_Entry_Index, Set_Prim_Op_Kind, OSD: They are used with types
-- that implement limited interfaces and are only invoked when there are
-- selective waits and ATC's where the trigger is a call to an interface
-- operation. These functions have been removed because selective waits
-- and ATC's are not supported by the restricted run-time.
-- Displace, IW_Membership, Offset_To_Top, Set_Dynamic_Offset_To_Top,
-- Base_Address, Register_Interface_Offset: They are used with extended
-- support for interface types that is not part of the zfp runtime
-- (membership test applied to interfaces, tagged types with variable
-- size components covering interfaces, explicit dereference through
-- access to interfaces, and unchecked deallocation through access to
-- interfaces).
-- The operations in this package provide the guarantee that all
-- dispatching calls on primitive operations of tagged types and
-- interfaces take constant time (in terms of source lines executed),
-- that is to say, the cost of these calls is independent of the number
-- of primitives of the type or interface, and independent of the number
-- of ancestors or interface progenitors that a tagged type may have.
with System;
with System.Storage_Elements;
with Ada.Unchecked_Conversion;
package Ada.Tags is
pragma Preelaborate;
-- In accordance with Ada 2005 AI-362
type Tag is private;
pragma Preelaborable_Initialization (Tag);
No_Tag : constant Tag;
function Expanded_Name (T : Tag) return String;
function External_Tag (T : Tag) return String;
function Parent_Tag (T : Tag) return Tag;
pragma Ada_05 (Parent_Tag);
Tag_Error : exception;
private
-- Structure of the GNAT Primary Dispatch Table
-- +--------------------+
-- | Predef_Prims ---------------------------> +------------+
-- +--------------------+ | table of |
-- |Typeinfo_Ptr/TSD_Ptr --> Type Specific Data | predefined |
-- Tag --> +--------------------+ +-------------------+ | primitives |
-- | table of | | inheritance depth | +------------+
-- : primitive ops : +-------------------+
-- | pointers | | access level |
-- +--------------------+ +-------------------+
-- | alignment |
-- +-------------------+
-- | expanded name |
-- +-------------------+
-- | external tag |
-- +-------------------+
-- | hash table link |
-- +-------------------+
-- | transportable |
-- +-------------------+
-- | needs finalization|
-- +-------------------+
-- | table of |
-- : ancestor :
-- | tags |
-- +-------------------+
-- The runtime information kept for each tagged type is separated into
-- three objects: the Dispatch Table of predefined primitives, the dispatch
-- table of user-defined primitives and the Type_Specific_Data record.
package SSE renames System.Storage_Elements;
subtype Cstring is String (Positive);
type Cstring_Ptr is access all Cstring;
pragma No_Strict_Aliasing (Cstring_Ptr);
type Tag_Table is array (Natural range <>) of Tag;
type Prim_Ptr is access procedure;
type Address_Array is array (Positive range <>) of Prim_Ptr;
subtype Dispatch_Table is Address_Array (1 .. 1);
-- Used by GDB to identify the _tags and traverse the run-time structure
-- associated with tagged types. For compatibility with older versions of
-- gdb, its name must not be changed.
type Tag is access all Dispatch_Table;
pragma No_Strict_Aliasing (Tag);
type Interface_Tag is access all Dispatch_Table;
No_Tag : constant Tag := null;
-- The expander ensures that Tag objects reference the Prims_Ptr component
-- of the wrapper.
type Tag_Ptr is access all Tag;
pragma No_Strict_Aliasing (Tag_Ptr);
type Offset_To_Top_Ptr is access all SSE.Storage_Offset;
pragma No_Strict_Aliasing (Offset_To_Top_Ptr);
type Type_Specific_Data (Idepth : Natural) is record
-- Inheritance Depth Level: Used to implement the membership test
-- associated with single inheritance of tagged types in constant-time.
-- It also indicates the size of the Tags_Table component.
Access_Level : Natural;
-- Accessibility level required to give support to Ada 2005 nested type
-- extensions. This feature allows safe nested type extensions by
-- shifting the accessibility checks to certain operations, rather than
-- being enforced at the type declaration. In particular, by performing
-- run-time accessibility checks on class-wide allocators, class-wide
-- function return, and class-wide stream I/O, the danger of objects
-- outliving their type declaration can be eliminated (Ada 2005: AI-344)
Alignment : Natural;
Expanded_Name : Cstring_Ptr;
External_Tag : Cstring_Ptr;
-- Components used to support to the Ada.Tags subprograms in ARM 3.9
-- Note: Expanded_Name is referenced by GDB to determine the actual name
-- of the tagged type. Its requirements are: 1) it must have this exact
-- name, and 2) its contents must point to a C-style Nul terminated
-- string containing its expanded name. GDB has no requirement on a
-- given position inside the record.
Transportable : Boolean;
-- Used to check RM E.4(18), set for types that satisfy the requirements
-- for being used in remote calls as actuals for classwide formals or as
-- return values for classwide functions.
Needs_Finalization : Boolean;
-- Used to dynamically check whether an object is controlled or not
Tags_Table : Tag_Table (0 .. Idepth);
-- Table of ancestor tags. Its size actually depends on the inheritance
-- depth level of the tagged type.
end record;
type Type_Specific_Data_Ptr is access all Type_Specific_Data;
pragma No_Strict_Aliasing (Type_Specific_Data_Ptr);
type Dispatch_Table_Wrapper (Num_Prims : Natural) is record
Predef_Prims : System.Address;
-- Pointer to the dispatch table of predefined Ada primitives
-- According to the C++ ABI the components Offset_To_Top and TSD are
-- stored just "before" the dispatch table (that is, the Prims_Ptr
-- table), and they are referenced with negative offsets referring to
-- the base of the dispatch table. The _Tag (or the VTable_Ptr in C++
-- terminology) must point to the base of the virtual table, just after
-- these components, to point to the Prims_Ptr table.
Offset_To_Top : SSE.Storage_Offset;
TSD : System.Address;
Prims_Ptr : Address_Array (1 .. Num_Prims);
-- The size of the Prims_Ptr array actually depends on the tagged type
-- to which it applies. For each tagged type, the expander computes the
-- actual array size, allocates the Dispatch_Table record accordingly.
end record;
-- The following type declaration is used by the compiler when the program
-- is compiled with restriction No_Dispatching_Calls
type No_Dispatch_Table_Wrapper is record
NDT_TSD : System.Address;
NDT_Prims_Ptr : Natural;
end record;
DT_Predef_Prims_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(1 * (Standard'Address_Size /
System.Storage_Unit));
-- Size of the Predef_Prims field of the Dispatch_Table
DT_Offset_To_Top_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(1 * (Standard'Address_Size /
System.Storage_Unit));
-- Size of the Offset_To_Top field of the Dispatch Table
DT_Typeinfo_Ptr_Size : constant SSE.Storage_Count :=
SSE.Storage_Count
(1 * (Standard'Address_Size /
System.Storage_Unit));
-- Size of the Typeinfo_Ptr field of the Dispatch Table
use type System.Storage_Elements.Storage_Offset;
DT_Offset_To_Top_Offset : constant SSE.Storage_Count :=
DT_Typeinfo_Ptr_Size
+ DT_Offset_To_Top_Size;
DT_Predef_Prims_Offset : constant SSE.Storage_Count :=
DT_Typeinfo_Ptr_Size
+ DT_Offset_To_Top_Size
+ DT_Predef_Prims_Size;
-- Offset from Prims_Ptr to Predef_Prims component
Max_Predef_Prims : constant Positive := 10;
-- Number of reserved slots for predefined ada primitives: Size, Read,
-- Write, Input, Output, "=", assignment, deep adjust, deep finalize,
-- and Put_Image.
-- The compiler checks that this value is correct.
subtype Predef_Prims_Table is Address_Array (1 .. Max_Predef_Prims);
type Predef_Prims_Table_Ptr is access Predef_Prims_Table;
pragma No_Strict_Aliasing (Predef_Prims_Table_Ptr);
type Addr_Ptr is access System.Address;
pragma No_Strict_Aliasing (Addr_Ptr);
-------------------
-- CW_Membership --
-------------------
function To_Address is
new Ada.Unchecked_Conversion (Tag, System.Address);
function To_Addr_Ptr is
new Ada.Unchecked_Conversion (System.Address, Addr_Ptr);
function To_Type_Specific_Data_Ptr is
new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
-- Canonical implementation of Classwide Membership corresponding to:
-- Obj in Typ'Class
-- Each dispatch table contains a reference to a table of ancestors (stored
-- in the first part of the Tags_Table) and a count of the level of
-- inheritance "Idepth".
-- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
-- contained in the dispatch table referenced by Obj'Tag . Knowing the
-- level of inheritance of both types, this can be computed in constant
-- time by the formula:
-- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
-- = Typ'tag
function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
(declare
Obj_TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (Obj_Tag) - DT_Typeinfo_Ptr_Size);
Typ_TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (Typ_Tag) - DT_Typeinfo_Ptr_Size);
Obj_TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (Obj_TSD_Ptr.all);
Typ_TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (Typ_TSD_Ptr.all);
Pos : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth;
begin
Pos >= 0 and then Obj_TSD.Tags_Table (Pos) = Typ_Tag);
-- Given the tag of an object and the tag associated to a type, return
-- true if Obj is in Typ'Class.
end Ada.Tags;
|