|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT RUN-TIME COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- A D A . T A G S --
|
|
|
6 -- --
|
|
|
7 -- S p e c --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
|
|
111
|
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 3, 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. --
|
|
|
21 -- --
|
|
|
22 -- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
|
23 -- additional permissions described in the GCC Runtime Library Exception, --
|
|
|
24 -- version 3.1, as published by the Free Software Foundation. --
|
|
|
25 -- --
|
|
|
26 -- You should have received a copy of the GNU General Public License and --
|
|
|
27 -- a copy of the GCC Runtime Library Exception along with this program; --
|
|
|
28 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
|
|
29 -- <http://www.gnu.org/licenses/>. --
|
|
|
30 -- --
|
|
|
31 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
32 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
33 -- --
|
|
|
34 ------------------------------------------------------------------------------
|
|
|
35
|
|
|
36 -- For performance analysis, take into account that the operations in this
|
|
|
37 -- package provide the guarantee that all dispatching calls on primitive
|
|
|
38 -- operations of tagged types and interfaces take constant time (in terms
|
|
|
39 -- of source lines executed), that is to say, the cost of these calls is
|
|
|
40 -- independent of the number of primitives of the type or interface, and
|
|
|
41 -- independent of the number of ancestors or interface progenitors that a
|
|
|
42 -- tagged type may have.
|
|
|
43
|
|
|
44 -- The following subprograms of the public part of this package take constant
|
|
|
45 -- time (in terms of source lines executed):
|
|
|
46
|
|
|
47 -- Expanded_Name, Wide_Expanded_Name, Wide_Wide_Expanded_Name, External_Tag,
|
|
|
48 -- Is_Abstract, Is_Descendant_At_Same_Level, Parent_Tag,
|
|
|
49 -- Descendant_Tag (when used with a library-level tagged type),
|
|
|
50 -- Internal_Tag (when used with a library-level tagged type).
|
|
|
51
|
|
|
52 -- The following subprograms of the public part of this package execute in
|
|
|
53 -- time that is not constant (in terms of sources line executed):
|
|
|
54
|
|
|
55 -- Internal_Tag (when used with a locally defined tagged type), because in
|
|
|
56 -- such cases this routine processes the external tag, extracts from it an
|
|
|
57 -- address available there, and converts it into the tag value returned by
|
|
|
58 -- this function. The number of instructions executed is not constant since
|
|
|
59 -- it depends on the length of the external tag string.
|
|
|
60
|
|
|
61 -- Descendant_Tag (when used with a locally defined tagged type), because
|
|
|
62 -- it relies on the subprogram Internal_Tag() to provide its functionality.
|
|
|
63
|
|
|
64 -- Interface_Ancestor_Tags, because this function returns a table whose
|
|
|
65 -- length depends on the number of interfaces covered by a tagged type.
|
|
|
66
|
|
|
67 with System.Storage_Elements;
|
|
|
68
|
|
|
69 package Ada.Tags is
|
|
|
70 pragma Preelaborate;
|
|
|
71 -- In accordance with Ada 2005 AI-362
|
|
|
72
|
|
|
73 type Tag is private;
|
|
|
74 pragma Preelaborable_Initialization (Tag);
|
|
|
75
|
|
|
76 No_Tag : constant Tag;
|
|
|
77
|
|
|
78 function Expanded_Name (T : Tag) return String;
|
|
|
79
|
|
|
80 function Wide_Expanded_Name (T : Tag) return Wide_String;
|
|
|
81 pragma Ada_05 (Wide_Expanded_Name);
|
|
|
82
|
|
|
83 function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String;
|
|
|
84 pragma Ada_05 (Wide_Wide_Expanded_Name);
|
|
|
85
|
|
|
86 function External_Tag (T : Tag) return String;
|
|
|
87
|
|
|
88 function Internal_Tag (External : String) return Tag;
|
|
|
89
|
|
|
90 function Descendant_Tag
|
|
|
91 (External : String;
|
|
|
92 Ancestor : Tag) return Tag;
|
|
|
93 pragma Ada_05 (Descendant_Tag);
|
|
|
94
|
|
|
95 function Is_Descendant_At_Same_Level
|
|
|
96 (Descendant : Tag;
|
|
|
97 Ancestor : Tag) return Boolean;
|
|
|
98 pragma Ada_05 (Is_Descendant_At_Same_Level);
|
|
|
99
|
|
|
100 function Parent_Tag (T : Tag) return Tag;
|
|
|
101 pragma Ada_05 (Parent_Tag);
|
|
|
102
|
|
|
103 type Tag_Array is array (Positive range <>) of Tag;
|
|
|
104
|
|
|
105 function Interface_Ancestor_Tags (T : Tag) return Tag_Array;
|
|
|
106 pragma Ada_05 (Interface_Ancestor_Tags);
|
|
|
107
|
|
|
108 function Is_Abstract (T : Tag) return Boolean;
|
|
|
109 pragma Ada_2012 (Is_Abstract);
|
|
|
110
|
|
|
111 Tag_Error : exception;
|
|
|
112
|
|
|
113 private
|
|
|
114 -- Structure of the GNAT Primary Dispatch Table
|
|
|
115
|
|
|
116 -- +--------------------+
|
|
|
117 -- | Signature |
|
|
|
118 -- +--------------------+
|
|
|
119 -- | Tagged_Kind |
|
|
|
120 -- +--------------------+ Predef Prims
|
|
|
121 -- | Predef_Prims -----------------------------> +------------+
|
|
|
122 -- +--------------------+ | table of |
|
|
|
123 -- | Offset_To_Top | | predefined |
|
|
|
124 -- +--------------------+ | primitives |
|
|
|
125 -- |Typeinfo_Ptr/TSD_Ptr---> Type Specific Data +------------+
|
|
|
126 -- Tag ---> +--------------------+ +-------------------+
|
|
|
127 -- | table of | | inheritance depth |
|
|
|
128 -- : primitive ops : +-------------------+
|
|
|
129 -- | pointers | | access level |
|
|
|
130 -- +--------------------+ +-------------------+
|
|
|
131 -- | alignment |
|
|
|
132 -- +-------------------+
|
|
|
133 -- | expanded name |
|
|
|
134 -- +-------------------+
|
|
|
135 -- | external tag |
|
|
|
136 -- +-------------------+
|
|
|
137 -- | hash table link |
|
|
|
138 -- +-------------------+
|
|
|
139 -- | transportable |
|
|
|
140 -- +-------------------+
|
|
|
141 -- | is_abstract |
|
|
|
142 -- +-------------------+
|
|
|
143 -- | needs finalization|
|
|
|
144 -- +-------------------+
|
|
|
145 -- | Ifaces_Table ---> Interface Data
|
|
|
146 -- +-------------------+ +------------+
|
|
|
147 -- Select Specific Data <---- SSD | | Nb_Ifaces |
|
|
|
148 -- +------------------+ +-------------------+ +------------+
|
|
|
149 -- |table of primitive| | table of | | table |
|
|
|
150 -- : operation : : ancestor : : of :
|
|
|
151 -- | kinds | | tags | | interfaces |
|
|
|
152 -- +------------------+ +-------------------+ +------------+
|
|
|
153 -- |table of |
|
|
|
154 -- : entry :
|
|
|
155 -- | indexes |
|
|
|
156 -- +------------------+
|
|
|
157
|
|
|
158 -- Structure of the GNAT Secondary Dispatch Table
|
|
|
159
|
|
|
160 -- +--------------------+
|
|
|
161 -- | Signature |
|
|
|
162 -- +--------------------+
|
|
|
163 -- | Tagged_Kind |
|
|
|
164 -- +--------------------+ Predef Prims
|
|
|
165 -- | Predef_Prims -----------------------------> +------------+
|
|
|
166 -- +--------------------+ | table of |
|
|
|
167 -- | Offset_To_Top | | predefined |
|
|
|
168 -- +--------------------+ | primitives |
|
|
|
169 -- | OSD_Ptr |---> Object Specific Data | thunks |
|
|
|
170 -- Tag ---> +--------------------+ +---------------+ +------------+
|
|
|
171 -- | table of | | num prim ops |
|
|
|
172 -- : primitive op : +---------------+
|
|
|
173 -- | thunk pointers | | table of |
|
|
|
174 -- +--------------------+ + primitive |
|
|
|
175 -- | op offsets |
|
|
|
176 -- +---------------+
|
|
|
177
|
|
|
178 -- The runtime information kept for each tagged type is separated into two
|
|
|
179 -- objects: the Dispatch Table and the Type Specific Data record.
|
|
|
180
|
|
|
181 package SSE renames System.Storage_Elements;
|
|
|
182
|
|
|
183 subtype Cstring is String (Positive);
|
|
|
184 type Cstring_Ptr is access all Cstring;
|
|
|
185 pragma No_Strict_Aliasing (Cstring_Ptr);
|
|
|
186
|
|
|
187 -- Declarations for the table of interfaces
|
|
|
188
|
|
|
189 type Offset_To_Top_Function_Ptr is
|
|
|
190 access function (This : System.Address) return SSE.Storage_Offset;
|
|
|
191 -- Type definition used to call the function that is generated by the
|
|
|
192 -- expander in case of tagged types with discriminants that have secondary
|
|
|
193 -- dispatch tables. This function provides the Offset_To_Top value in this
|
|
|
194 -- specific case.
|
|
|
195
|
|
|
196 type Interface_Data_Element is record
|
|
|
197 Iface_Tag : Tag;
|
|
|
198 Static_Offset_To_Top : Boolean;
|
|
|
199 Offset_To_Top_Value : SSE.Storage_Offset;
|
|
|
200 Offset_To_Top_Func : Offset_To_Top_Function_Ptr;
|
|
|
201 Secondary_DT : Tag;
|
|
|
202 end record;
|
|
|
203 -- If some ancestor of the tagged type has discriminants the field
|
|
|
204 -- Static_Offset_To_Top is False and the field Offset_To_Top_Func
|
|
|
205 -- is used to store the access to the function generated by the
|
|
|
206 -- expander which provides this value; otherwise Static_Offset_To_Top
|
|
|
207 -- is True and such value is stored in the Offset_To_Top_Value field.
|
|
|
208 -- Secondary_DT references a secondary dispatch table whose contents
|
|
|
209 -- are pointers to the primitives of the tagged type that cover the
|
|
|
210 -- interface primitives. Secondary_DT gives support to dispatching
|
|
|
211 -- calls through interface types associated with Generic Dispatching
|
|
|
212 -- Constructors.
|
|
|
213
|
|
|
214 type Interfaces_Array is array (Natural range <>) of Interface_Data_Element;
|
|
|
215
|
|
|
216 type Interface_Data (Nb_Ifaces : Positive) is record
|
|
|
217 Ifaces_Table : Interfaces_Array (1 .. Nb_Ifaces);
|
|
|
218 end record;
|
|
|
219
|
|
|
220 type Interface_Data_Ptr is access all Interface_Data;
|
|
|
221 -- Table of abstract interfaces used to give support to backward interface
|
|
|
222 -- conversions and also to IW_Membership.
|
|
|
223
|
|
|
224 -- Primitive operation kinds. These values differentiate the kinds of
|
|
|
225 -- callable entities stored in the dispatch table. Certain kinds may
|
|
|
226 -- not be used, but are added for completeness.
|
|
|
227
|
|
|
228 type Prim_Op_Kind is
|
|
|
229 (POK_Function,
|
|
|
230 POK_Procedure,
|
|
|
231 POK_Protected_Entry,
|
|
|
232 POK_Protected_Function,
|
|
|
233 POK_Protected_Procedure,
|
|
|
234 POK_Task_Entry,
|
|
|
235 POK_Task_Function,
|
|
|
236 POK_Task_Procedure);
|
|
|
237
|
|
|
238 -- Select specific data types
|
|
|
239
|
|
|
240 type Select_Specific_Data_Element is record
|
|
|
241 Index : Positive;
|
|
|
242 Kind : Prim_Op_Kind;
|
|
|
243 end record;
|
|
|
244
|
|
|
245 type Select_Specific_Data_Array is
|
|
|
246 array (Positive range <>) of Select_Specific_Data_Element;
|
|
|
247
|
|
|
248 type Select_Specific_Data (Nb_Prim : Positive) is record
|
|
|
249 SSD_Table : Select_Specific_Data_Array (1 .. Nb_Prim);
|
|
|
250 -- NOTE: Nb_Prim is the number of non-predefined primitive operations
|
|
|
251 end record;
|
|
|
252
|
|
|
253 type Select_Specific_Data_Ptr is access all Select_Specific_Data;
|
|
|
254 -- A table used to store the primitive operation kind and entry index of
|
|
|
255 -- primitive subprograms of a type that implements a limited interface.
|
|
|
256 -- The Select Specific Data table resides in the Type Specific Data of a
|
|
|
257 -- type. This construct is used in the handling of dispatching triggers
|
|
|
258 -- in select statements.
|
|
|
259
|
|
|
260 type Prim_Ptr is access procedure;
|
|
|
261 type Address_Array is array (Positive range <>) of Prim_Ptr;
|
|
|
262
|
|
|
263 subtype Dispatch_Table is Address_Array (1 .. 1);
|
|
|
264 -- Used by GDB to identify the _tags and traverse the run-time structure
|
|
|
265 -- associated with tagged types. For compatibility with older versions of
|
|
|
266 -- gdb, its name must not be changed.
|
|
|
267
|
|
|
268 type Tag is access all Dispatch_Table;
|
|
|
269 pragma No_Strict_Aliasing (Tag);
|
|
|
270
|
|
|
271 type Interface_Tag is access all Dispatch_Table;
|
|
|
272
|
|
|
273 No_Tag : constant Tag := null;
|
|
|
274
|
|
|
275 -- The expander ensures that Tag objects reference the Prims_Ptr component
|
|
|
276 -- of the wrapper.
|
|
|
277
|
|
|
278 type Tag_Ptr is access all Tag;
|
|
|
279 pragma No_Strict_Aliasing (Tag_Ptr);
|
|
|
280
|
|
|
281 type Offset_To_Top_Ptr is access all SSE.Storage_Offset;
|
|
|
282 pragma No_Strict_Aliasing (Offset_To_Top_Ptr);
|
|
|
283
|
|
|
284 type Tag_Table is array (Natural range <>) of Tag;
|
|
|
285
|
|
|
286 type Size_Ptr is
|
|
|
287 access function (A : System.Address) return Long_Long_Integer;
|
|
|
288
|
|
|
289 type Type_Specific_Data (Idepth : Natural) is record
|
|
|
290 -- The discriminant Idepth is the Inheritance Depth Level: Used to
|
|
|
291 -- implement the membership test associated with single inheritance of
|
|
|
292 -- tagged types in constant-time. It also indicates the size of the
|
|
|
293 -- Tags_Table component.
|
|
|
294
|
|
|
295 Access_Level : Natural;
|
|
|
296 -- Accessibility level required to give support to Ada 2005 nested type
|
|
|
297 -- extensions. This feature allows safe nested type extensions by
|
|
|
298 -- shifting the accessibility checks to certain operations, rather than
|
|
|
299 -- being enforced at the type declaration. In particular, by performing
|
|
|
300 -- run-time accessibility checks on class-wide allocators, class-wide
|
|
|
301 -- function return, and class-wide stream I/O, the danger of objects
|
|
|
302 -- outliving their type declaration can be eliminated (Ada 2005: AI-344)
|
|
|
303
|
|
|
304 Alignment : Natural;
|
|
|
305 Expanded_Name : Cstring_Ptr;
|
|
|
306 External_Tag : Cstring_Ptr;
|
|
|
307 HT_Link : Tag_Ptr;
|
|
|
308 -- Components used to support to the Ada.Tags subprograms in RM 3.9
|
|
|
309
|
|
|
310 -- Note: Expanded_Name is referenced by GDB to determine the actual name
|
|
|
311 -- of the tagged type. Its requirements are: 1) it must have this exact
|
|
|
312 -- name, and 2) its contents must point to a C-style Nul terminated
|
|
|
313 -- string containing its expanded name. GDB has no requirement on a
|
|
|
314 -- given position inside the record.
|
|
|
315
|
|
|
316 Transportable : Boolean;
|
|
|
317 -- Used to check RM E.4(18), set for types that satisfy the requirements
|
|
|
318 -- for being used in remote calls as actuals for classwide formals or as
|
|
|
319 -- return values for classwide functions.
|
|
|
320
|
|
|
321 Is_Abstract : Boolean;
|
|
|
322 -- True if the type is abstract (Ada 2012: AI05-0173)
|
|
|
323
|
|
|
324 Needs_Finalization : Boolean;
|
|
|
325 -- Used to dynamically check whether an object is controlled or not
|
|
|
326
|
|
|
327 Size_Func : Size_Ptr;
|
|
|
328 -- Pointer to the subprogram computing the _size of the object. Used by
|
|
|
329 -- the run-time whenever a call to the 'size primitive is required. We
|
|
|
330 -- cannot assume that the contents of dispatch tables are addresses
|
|
|
331 -- because in some architectures the ABI allows descriptors.
|
|
|
332
|
|
|
333 Interfaces_Table : Interface_Data_Ptr;
|
|
|
334 -- Pointer to the table of interface tags. It is used to implement the
|
|
|
335 -- membership test associated with interfaces and also for backward
|
|
|
336 -- abstract interface type conversions (Ada 2005:AI-251)
|
|
|
337
|
|
|
338 SSD : Select_Specific_Data_Ptr;
|
|
|
339 -- Pointer to a table of records used in dispatching selects. This field
|
|
|
340 -- has a meaningful value for all tagged types that implement a limited,
|
|
|
341 -- protected, synchronized or task interfaces and have non-predefined
|
|
|
342 -- primitive operations.
|
|
|
343
|
|
|
344 Tags_Table : Tag_Table (0 .. Idepth);
|
|
|
345 -- Table of ancestor tags. Its size actually depends on the inheritance
|
|
|
346 -- depth level of the tagged type.
|
|
|
347 end record;
|
|
|
348
|
|
|
349 type Type_Specific_Data_Ptr is access all Type_Specific_Data;
|
|
|
350 pragma No_Strict_Aliasing (Type_Specific_Data_Ptr);
|
|
|
351
|
|
|
352 -- Declarations for the dispatch table record
|
|
|
353
|
|
|
354 type Signature_Kind is
|
|
|
355 (Unknown,
|
|
|
356 Primary_DT,
|
|
|
357 Secondary_DT);
|
|
|
358
|
|
|
359 -- Tagged type kinds with respect to concurrency and limitedness
|
|
|
360
|
|
|
361 type Tagged_Kind is
|
|
|
362 (TK_Abstract_Limited_Tagged,
|
|
|
363 TK_Abstract_Tagged,
|
|
|
364 TK_Limited_Tagged,
|
|
|
365 TK_Protected,
|
|
|
366 TK_Tagged,
|
|
|
367 TK_Task);
|
|
|
368
|
|
|
369 type Dispatch_Table_Wrapper (Num_Prims : Natural) is record
|
|
|
370 Signature : Signature_Kind;
|
|
|
371 Tag_Kind : Tagged_Kind;
|
|
|
372 Predef_Prims : System.Address;
|
|
|
373 -- Pointer to the dispatch table of predefined Ada primitives
|
|
|
374
|
|
|
375 -- According to the C++ ABI the components Offset_To_Top and TSD are
|
|
|
376 -- stored just "before" the dispatch table, and they are referenced with
|
|
|
377 -- negative offsets referring to the base of the dispatch table. The
|
|
|
378 -- _Tag (or the VTable_Ptr in C++ terminology) must point to the base
|
|
|
379 -- of the virtual table, just after these components, to point to the
|
|
|
380 -- Prims_Ptr table.
|
|
|
381
|
|
|
382 Offset_To_Top : SSE.Storage_Offset;
|
|
|
383 -- Offset between the _Tag field and the field that contains the
|
|
|
384 -- reference to this dispatch table. For primary dispatch tables it is
|
|
|
385 -- zero. For secondary dispatch tables: if the parent record type (if
|
|
|
386 -- any) has a compile-time-known size, then Offset_To_Top contains the
|
|
|
387 -- expected value, otherwise it contains SSE.Storage_Offset'Last and the
|
|
|
388 -- actual offset is to be found in the tagged record, right after the
|
|
|
389 -- field that contains the reference to this dispatch table. See the
|
|
|
390 -- implementation of Ada.Tags.Offset_To_Top for the corresponding logic.
|
|
|
391
|
|
|
392 TSD : System.Address;
|
|
|
393
|
|
|
394 Prims_Ptr : aliased Address_Array (1 .. Num_Prims);
|
|
|
395 -- The size of the Prims_Ptr array actually depends on the tagged type
|
|
|
396 -- to which it applies. For each tagged type, the expander computes the
|
|
|
397 -- actual array size, allocating the Dispatch_Table record accordingly.
|
|
|
398 end record;
|
|
|
399
|
|
|
400 type Dispatch_Table_Ptr is access all Dispatch_Table_Wrapper;
|
|
|
401 pragma No_Strict_Aliasing (Dispatch_Table_Ptr);
|
|
|
402
|
|
|
403 -- The following type declaration is used by the compiler when the program
|
|
|
404 -- is compiled with restriction No_Dispatching_Calls. It is also used with
|
|
|
405 -- interface types to generate the tag and run-time information associated
|
|
|
406 -- with them.
|
|
|
407
|
|
|
408 type No_Dispatch_Table_Wrapper is record
|
|
|
409 NDT_TSD : System.Address;
|
|
|
410 NDT_Prims_Ptr : Natural;
|
|
|
411 end record;
|
|
|
412
|
|
|
413 DT_Predef_Prims_Size : constant SSE.Storage_Count :=
|
|
|
414 SSE.Storage_Count
|
|
|
415 (1 * (Standard'Address_Size /
|
|
|
416 System.Storage_Unit));
|
|
|
417 -- Size of the Predef_Prims field of the Dispatch_Table
|
|
|
418
|
|
|
419 DT_Offset_To_Top_Size : constant SSE.Storage_Count :=
|
|
|
420 SSE.Storage_Count
|
|
|
421 (1 * (Standard'Address_Size /
|
|
|
422 System.Storage_Unit));
|
|
|
423 -- Size of the Offset_To_Top field of the Dispatch Table
|
|
|
424
|
|
|
425 DT_Typeinfo_Ptr_Size : constant SSE.Storage_Count :=
|
|
|
426 SSE.Storage_Count
|
|
|
427 (1 * (Standard'Address_Size /
|
|
|
428 System.Storage_Unit));
|
|
|
429 -- Size of the Typeinfo_Ptr field of the Dispatch Table
|
|
|
430
|
|
|
431 use type System.Storage_Elements.Storage_Offset;
|
|
|
432
|
|
|
433 DT_Offset_To_Top_Offset : constant SSE.Storage_Count :=
|
|
|
434 DT_Typeinfo_Ptr_Size
|
|
|
435 + DT_Offset_To_Top_Size;
|
|
|
436
|
|
|
437 DT_Predef_Prims_Offset : constant SSE.Storage_Count :=
|
|
|
438 DT_Typeinfo_Ptr_Size
|
|
|
439 + DT_Offset_To_Top_Size
|
|
|
440 + DT_Predef_Prims_Size;
|
|
|
441 -- Offset from Prims_Ptr to Predef_Prims component
|
|
|
442
|
|
|
443 -- Object Specific Data record of secondary dispatch tables
|
|
|
444
|
|
|
445 type Object_Specific_Data_Array is array (Positive range <>) of Positive;
|
|
|
446
|
|
|
447 type Object_Specific_Data (OSD_Num_Prims : Positive) is record
|
|
|
448 OSD_Table : Object_Specific_Data_Array (1 .. OSD_Num_Prims);
|
|
|
449 -- Table used in secondary DT to reference their counterpart in the
|
|
|
450 -- select specific data (in the TSD of the primary DT). This construct
|
|
|
451 -- is used in the handling of dispatching triggers in select statements.
|
|
|
452 -- Nb_Prim is the number of non-predefined primitive operations.
|
|
|
453 end record;
|
|
|
454
|
|
|
455 type Object_Specific_Data_Ptr is access all Object_Specific_Data;
|
|
|
456 pragma No_Strict_Aliasing (Object_Specific_Data_Ptr);
|
|
|
457
|
|
|
458 -- The following subprogram specifications are placed here instead of the
|
|
|
459 -- package body to see them from the frontend through rtsfind.
|
|
|
460
|
|
|
461 function Base_Address (This : System.Address) return System.Address;
|
|
|
462 -- Ada 2005 (AI-251): Displace "This" to point to the base address of the
|
|
|
463 -- object (that is, the address of the primary tag of the object).
|
|
|
464
|
|
|
465 procedure Check_TSD (TSD : Type_Specific_Data_Ptr);
|
|
|
466 -- Ada 2012 (AI-113): Raise Program_Error if the external tag of this TSD
|
|
|
467 -- is the same as the external tag for some other tagged type declaration.
|
|
|
468
|
|
|
469 function Displace (This : System.Address; T : Tag) return System.Address;
|
|
|
470 -- Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch
|
|
|
471 -- table of T.
|
|
|
472
|
|
|
473 function Secondary_Tag (T, Iface : Tag) return Tag;
|
|
|
474 -- Ada 2005 (AI-251): Given a primary tag T associated with a tagged type
|
|
|
475 -- Typ, search for the secondary tag of the interface type Iface covered
|
|
|
476 -- by Typ.
|
|
|
477
|
|
|
478 function DT (T : Tag) return Dispatch_Table_Ptr;
|
|
|
479 -- Return the pointer to the TSD record associated with T
|
|
|
480
|
|
|
481 function Get_Entry_Index (T : Tag; Position : Positive) return Positive;
|
|
|
482 -- Ada 2005 (AI-251): Return a primitive operation's entry index (if entry)
|
|
|
483 -- given a dispatch table T and a position of a primitive operation in T.
|
|
|
484
|
|
|
485 function Get_Offset_Index
|
|
|
486 (T : Tag;
|
|
|
487 Position : Positive) return Positive;
|
|
|
488 -- Ada 2005 (AI-251): Given a pointer to a secondary dispatch table (T)
|
|
|
489 -- and a position of an operation in the DT, retrieve the corresponding
|
|
|
490 -- operation's position in the primary dispatch table from the Offset
|
|
|
491 -- Specific Data table of T.
|
|
|
492
|
|
|
493 function Get_Prim_Op_Kind
|
|
|
494 (T : Tag;
|
|
|
495 Position : Positive) return Prim_Op_Kind;
|
|
|
496 -- Ada 2005 (AI-251): Return a primitive operation's kind given a dispatch
|
|
|
497 -- table T and a position of a primitive operation in T.
|
|
|
498
|
|
|
499 function Get_Tagged_Kind (T : Tag) return Tagged_Kind;
|
|
|
500 -- Ada 2005 (AI-345): Given a pointer to either a primary or a secondary
|
|
|
501 -- dispatch table, return the tagged kind of a type in the context of
|
|
|
502 -- concurrency and limitedness.
|
|
|
503
|
|
|
504 function IW_Membership (This : System.Address; T : Tag) return Boolean;
|
|
|
505 -- Ada 2005 (AI-251): General routine that checks if a given object
|
|
|
506 -- implements a tagged type. Its common usage is to check if Obj is in
|
|
|
507 -- Iface'Class, but it is also used to check if a class-wide interface
|
|
|
508 -- implements a given type (Iface_CW_Typ in T'Class). For example:
|
|
|
509 --
|
|
|
510 -- type I is interface;
|
|
|
511 -- type T is tagged ...
|
|
|
512 --
|
|
|
513 -- function Test (O : I'Class) is
|
|
|
514 -- begin
|
|
|
515 -- return O in T'Class.
|
|
|
516 -- end Test;
|
|
|
517
|
|
|
518 function Offset_To_Top
|
|
|
519 (This : System.Address) return SSE.Storage_Offset;
|
|
|
520 -- Ada 2005 (AI-251): Returns the current value of the Offset_To_Top
|
|
|
521 -- component available in the prologue of the dispatch table. If the parent
|
|
|
522 -- of the tagged type has discriminants this value is stored in a record
|
|
|
523 -- component just immediately after the tag component.
|
|
|
524
|
|
|
525 function Needs_Finalization (T : Tag) return Boolean;
|
|
|
526 -- A helper routine used in conjunction with finalization collections which
|
|
|
527 -- service class-wide types. The function dynamically determines whether an
|
|
|
528 -- object is controlled or has controlled components.
|
|
|
529
|
|
|
530 function Parent_Size
|
|
|
531 (Obj : System.Address;
|
|
|
532 T : Tag) return SSE.Storage_Count;
|
|
|
533 -- Computes the size the ancestor part of a tagged extension object whose
|
|
|
534 -- address is 'obj' by calling indirectly the ancestor _size function. The
|
|
|
535 -- ancestor is the parent of the type represented by tag T. This function
|
|
|
536 -- assumes that _size is always in slot one of the dispatch table.
|
|
|
537
|
|
|
538 procedure Register_Interface_Offset
|
|
|
539 (Prim_T : Tag;
|
|
|
540 Interface_T : Tag;
|
|
|
541 Is_Static : Boolean;
|
|
|
542 Offset_Value : SSE.Storage_Offset;
|
|
|
543 Offset_Func : Offset_To_Top_Function_Ptr);
|
|
|
544 -- Register in the table of interfaces of the tagged type associated with
|
|
|
545 -- Prim_T the offset of the record component associated with the progenitor
|
|
|
546 -- Interface_T (that is, the distance from "This" to the object component
|
|
|
547 -- containing the tag of the secondary dispatch table). In case of constant
|
|
|
548 -- offset, Is_Static is true and Offset_Value has such value. In case of
|
|
|
549 -- variable offset, Is_Static is false and Offset_Func is an access to
|
|
|
550 -- function that must be called to evaluate the offset.
|
|
|
551
|
|
|
552 procedure Register_Tag (T : Tag);
|
|
|
553 -- Insert the Tag and its associated external_tag in a table for the sake
|
|
|
554 -- of Internal_Tag.
|
|
|
555
|
|
|
556 procedure Set_Dynamic_Offset_To_Top
|
|
|
557 (This : System.Address;
|
|
|
558 Prim_T : Tag;
|
|
|
559 Interface_T : Tag;
|
|
|
560 Offset_Value : SSE.Storage_Offset;
|
|
|
561 Offset_Func : Offset_To_Top_Function_Ptr);
|
|
|
562 -- Ada 2005 (AI-251): The compiler generates calls to this routine only
|
|
|
563 -- when initializing the Offset_To_Top field of dispatch tables of tagged
|
|
|
564 -- types that cover interface types whose parent type has variable size
|
|
|
565 -- components.
|
|
|
566 --
|
|
|
567 -- "This" is the object whose dispatch table is being initialized. Prim_T
|
|
|
568 -- is the primary tag of such object. Interface_T is the interface tag for
|
|
|
569 -- which the secondary dispatch table is being initialized. Offset_Value
|
|
|
570 -- is the distance from "This" to the object component containing the tag
|
|
|
571 -- of the secondary dispatch table (a zero value means that this interface
|
|
|
572 -- shares the primary dispatch table). Offset_Func references a function
|
|
|
573 -- that must be called to evaluate the offset at run time. This routine
|
|
|
574 -- also takes care of registering these values in the table of interfaces
|
|
|
575 -- of the type.
|
|
|
576
|
|
|
577 procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive);
|
|
|
578 -- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's
|
|
|
579 -- TSD table indexed by Position.
|
|
|
580
|
|
|
581 procedure Set_Prim_Op_Kind
|
|
|
582 (T : Tag;
|
|
|
583 Position : Positive;
|
|
|
584 Value : Prim_Op_Kind);
|
|
|
585 -- Ada 2005 (AI-251): Set the kind of a primitive operation in T's TSD
|
|
|
586 -- table indexed by Position.
|
|
|
587
|
|
|
588 procedure Unregister_Tag (T : Tag);
|
|
|
589 -- Remove a particular tag from the external tag hash table
|
|
|
590
|
|
|
591 Max_Predef_Prims : constant Positive := 15;
|
|
|
592 -- Number of reserved slots for the following predefined ada primitives:
|
|
|
593 --
|
|
|
594 -- 1. Size
|
|
|
595 -- 2. Read
|
|
|
596 -- 3. Write
|
|
|
597 -- 4. Input
|
|
|
598 -- 5. Output
|
|
|
599 -- 6. "="
|
|
|
600 -- 7. assignment
|
|
|
601 -- 8. deep adjust
|
|
|
602 -- 9. deep finalize
|
|
|
603 -- 10. async select
|
|
|
604 -- 11. conditional select
|
|
|
605 -- 12. prim_op kind
|
|
|
606 -- 13. task_id
|
|
|
607 -- 14. dispatching requeue
|
|
|
608 -- 15. timed select
|
|
|
609 --
|
|
|
610 -- The compiler checks that the value here is correct
|
|
|
611
|
|
|
612 subtype Predef_Prims_Table is Address_Array (1 .. Max_Predef_Prims);
|
|
|
613 type Predef_Prims_Table_Ptr is access Predef_Prims_Table;
|
|
|
614 pragma No_Strict_Aliasing (Predef_Prims_Table_Ptr);
|
|
|
615
|
|
|
616 type Addr_Ptr is access System.Address;
|
|
|
617 pragma No_Strict_Aliasing (Addr_Ptr);
|
|
|
618 -- This type is used by the frontend to generate the code that handles
|
|
|
619 -- dispatch table slots of types declared at the local level.
|
|
|
620
|
|
|
621 end Ada.Tags;
|
