|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT RUN-TIME COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- A D A . T A G S --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
|
9 -- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
|
|
|
10 -- --
|
|
|
11 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
|
12 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
|
|
|
17 -- --
|
|
|
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
|
19 -- additional permissions described in the GCC Runtime Library Exception, --
|
|
|
20 -- version 3.1, as published by the Free Software Foundation. --
|
|
|
21 -- --
|
|
|
22 -- You should have received a copy of the GNU General Public License and --
|
|
|
23 -- a copy of the GCC Runtime Library Exception along with this program; --
|
|
|
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
|
|
25 -- <http://www.gnu.org/licenses/>. --
|
|
|
26 -- --
|
|
|
27 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
29 -- --
|
|
|
30 ------------------------------------------------------------------------------
|
|
|
31
|
|
|
32 with Ada.Exceptions;
|
|
|
33 with Ada.Unchecked_Conversion;
|
|
|
34
|
|
|
35 with System.HTable;
|
|
|
36 with System.Storage_Elements; use System.Storage_Elements;
|
|
|
37 with System.WCh_Con; use System.WCh_Con;
|
|
|
38 with System.WCh_StW; use System.WCh_StW;
|
|
|
39
|
|
|
40 pragma Elaborate (System.HTable);
|
|
|
41 -- Elaborate needed instead of Elaborate_All to avoid elaboration cycles
|
|
|
42 -- when polling is turned on. This is safe because HTable doesn't do anything
|
|
|
43 -- at elaboration time; it just contains a generic package we want to
|
|
|
44 -- instantiate.
|
|
|
45
|
|
|
46 package body Ada.Tags is
|
|
|
47
|
|
|
48 -----------------------
|
|
|
49 -- Local Subprograms --
|
|
|
50 -----------------------
|
|
|
51
|
|
|
52 function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
|
|
|
53 -- Given the tag of an object and the tag associated to a type, return
|
|
|
54 -- true if Obj is in Typ'Class.
|
|
|
55
|
|
|
56 function Get_External_Tag (T : Tag) return System.Address;
|
|
|
57 -- Returns address of a null terminated string containing the external name
|
|
|
58
|
|
|
59 function Is_Primary_DT (T : Tag) return Boolean;
|
|
|
60 -- Given a tag returns True if it has the signature of a primary dispatch
|
|
|
61 -- table. This is Inline_Always since it is called from other Inline_
|
|
|
62 -- Always subprograms where we want no out of line code to be generated.
|
|
|
63
|
|
|
64 function IW_Membership
|
|
|
65 (Descendant_TSD : Type_Specific_Data_Ptr;
|
|
|
66 T : Tag) return Boolean;
|
|
|
67 -- Subsidiary function of IW_Membership and CW_Membership which factorizes
|
|
|
68 -- the functionality needed to check if a given descendant implements an
|
|
|
69 -- interface tag T.
|
|
|
70
|
|
|
71 function Length (Str : Cstring_Ptr) return Natural;
|
|
|
72 -- Length of string represented by the given pointer (treating the string
|
|
|
73 -- as a C-style string, which is Nul terminated). See comment in body
|
|
|
74 -- explaining why we cannot use the normal strlen built-in.
|
|
|
75
|
|
|
76 function OSD (T : Tag) return Object_Specific_Data_Ptr;
|
|
|
77 -- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table,
|
|
|
78 -- retrieve the address of the record containing the Object Specific
|
|
|
79 -- Data table.
|
|
|
80
|
|
|
81 function SSD (T : Tag) return Select_Specific_Data_Ptr;
|
|
|
82 -- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, retrieves the
|
|
|
83 -- address of the record containing the Select Specific Data in T's TSD.
|
|
|
84
|
|
|
85 pragma Inline_Always (CW_Membership);
|
|
|
86 pragma Inline_Always (Get_External_Tag);
|
|
|
87 pragma Inline_Always (Is_Primary_DT);
|
|
|
88 pragma Inline_Always (OSD);
|
|
|
89 pragma Inline_Always (SSD);
|
|
|
90
|
|
|
91 -- Unchecked conversions
|
|
|
92
|
|
|
93 function To_Address is
|
|
|
94 new Unchecked_Conversion (Cstring_Ptr, System.Address);
|
|
|
95
|
|
|
96 function To_Cstring_Ptr is
|
|
|
97 new Unchecked_Conversion (System.Address, Cstring_Ptr);
|
|
|
98
|
|
|
99 -- Disable warnings on possible aliasing problem
|
|
|
100
|
|
|
101 function To_Tag is
|
|
|
102 new Unchecked_Conversion (Integer_Address, Tag);
|
|
|
103
|
|
|
104 function To_Addr_Ptr is
|
|
|
105 new Ada.Unchecked_Conversion (System.Address, Addr_Ptr);
|
|
|
106
|
|
|
107 function To_Address is
|
|
|
108 new Ada.Unchecked_Conversion (Tag, System.Address);
|
|
|
109
|
|
|
110 function To_Dispatch_Table_Ptr is
|
|
|
111 new Ada.Unchecked_Conversion (Tag, Dispatch_Table_Ptr);
|
|
|
112
|
|
|
113 function To_Dispatch_Table_Ptr is
|
|
|
114 new Ada.Unchecked_Conversion (System.Address, Dispatch_Table_Ptr);
|
|
|
115
|
|
|
116 function To_Object_Specific_Data_Ptr is
|
|
|
117 new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr);
|
|
|
118
|
|
|
119 function To_Tag_Ptr is
|
|
|
120 new Ada.Unchecked_Conversion (System.Address, Tag_Ptr);
|
|
|
121
|
|
|
122 function To_Type_Specific_Data_Ptr is
|
|
|
123 new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
|
|
|
124
|
|
|
125 -------------------------------
|
|
|
126 -- Inline_Always Subprograms --
|
|
|
127 -------------------------------
|
|
|
128
|
|
|
129 -- Inline_always subprograms must be placed before their first call to
|
|
|
130 -- avoid defeating the frontend inlining mechanism and thus ensure the
|
|
|
131 -- generation of their correct debug info.
|
|
|
132
|
|
|
133 -------------------
|
|
|
134 -- CW_Membership --
|
|
|
135 -------------------
|
|
|
136
|
|
|
137 -- Canonical implementation of Classwide Membership corresponding to:
|
|
|
138
|
|
|
139 -- Obj in Typ'Class
|
|
|
140
|
|
|
141 -- Each dispatch table contains a reference to a table of ancestors (stored
|
|
|
142 -- in the first part of the Tags_Table) and a count of the level of
|
|
|
143 -- inheritance "Idepth".
|
|
|
144
|
|
|
145 -- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
|
|
|
146 -- contained in the dispatch table referenced by Obj'Tag . Knowing the
|
|
|
147 -- level of inheritance of both types, this can be computed in constant
|
|
|
148 -- time by the formula:
|
|
|
149
|
|
|
150 -- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
|
|
|
151 -- = Typ'tag
|
|
|
152
|
|
|
153 function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
|
|
|
154 Obj_TSD_Ptr : constant Addr_Ptr :=
|
|
|
155 To_Addr_Ptr (To_Address (Obj_Tag) - DT_Typeinfo_Ptr_Size);
|
|
|
156 Typ_TSD_Ptr : constant Addr_Ptr :=
|
|
|
157 To_Addr_Ptr (To_Address (Typ_Tag) - DT_Typeinfo_Ptr_Size);
|
|
|
158 Obj_TSD : constant Type_Specific_Data_Ptr :=
|
|
|
159 To_Type_Specific_Data_Ptr (Obj_TSD_Ptr.all);
|
|
|
160 Typ_TSD : constant Type_Specific_Data_Ptr :=
|
|
|
161 To_Type_Specific_Data_Ptr (Typ_TSD_Ptr.all);
|
|
|
162 Pos : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth;
|
|
|
163 begin
|
|
|
164 return Pos >= 0 and then Obj_TSD.Tags_Table (Pos) = Typ_Tag;
|
|
|
165 end CW_Membership;
|
|
|
166
|
|
|
167 ----------------------
|
|
|
168 -- Get_External_Tag --
|
|
|
169 ----------------------
|
|
|
170
|
|
|
171 function Get_External_Tag (T : Tag) return System.Address is
|
|
|
172 TSD_Ptr : constant Addr_Ptr :=
|
|
|
173 To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
|
|
|
174 TSD : constant Type_Specific_Data_Ptr :=
|
|
|
175 To_Type_Specific_Data_Ptr (TSD_Ptr.all);
|
|
|
176 begin
|
|
|
177 return To_Address (TSD.External_Tag);
|
|
|
178 end Get_External_Tag;
|
|
|
179
|
|
|
180 -----------------
|
|
|
181 -- Is_Abstract --
|
|
|
182 -----------------
|
|
|
183
|
|
|
184 function Is_Abstract (T : Tag) return Boolean is
|
|
|
185 TSD_Ptr : Addr_Ptr;
|
|
|
186 TSD : Type_Specific_Data_Ptr;
|
|
|
187
|
|
|
188 begin
|
|
|
189 if T = No_Tag then
|
|
|
190 raise Tag_Error;
|
|
|
191 end if;
|
|
|
192
|
|
|
193 TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
|
|
|
194 TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
|
|
|
195 return TSD.Is_Abstract;
|
|
|
196 end Is_Abstract;
|
|
|
197
|
|
|
198 -------------------
|
|
|
199 -- Is_Primary_DT --
|
|
|
200 -------------------
|
|
|
201
|
|
|
202 function Is_Primary_DT (T : Tag) return Boolean is
|
|
|
203 begin
|
|
|
204 return DT (T).Signature = Primary_DT;
|
|
|
205 end Is_Primary_DT;
|
|
|
206
|
|
|
207 ---------
|
|
|
208 -- OSD --
|
|
|
209 ---------
|
|
|
210
|
|
|
211 function OSD (T : Tag) return Object_Specific_Data_Ptr is
|
|
|
212 OSD_Ptr : constant Addr_Ptr :=
|
|
|
213 To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
|
|
|
214 begin
|
|
|
215 return To_Object_Specific_Data_Ptr (OSD_Ptr.all);
|
|
|
216 end OSD;
|
|
|
217
|
|
|
218 ---------
|
|
|
219 -- SSD --
|
|
|
220 ---------
|
|
|
221
|
|
|
222 function SSD (T : Tag) return Select_Specific_Data_Ptr is
|
|
|
223 TSD_Ptr : constant Addr_Ptr :=
|
|
|
224 To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
|
|
|
225 TSD : constant Type_Specific_Data_Ptr :=
|
|
|
226 To_Type_Specific_Data_Ptr (TSD_Ptr.all);
|
|
|
227 begin
|
|
|
228 return TSD.SSD;
|
|
|
229 end SSD;
|
|
|
230
|
|
|
231 -------------------------
|
|
|
232 -- External_Tag_HTable --
|
|
|
233 -------------------------
|
|
|
234
|
|
|
235 type HTable_Headers is range 1 .. 64;
|
|
|
236
|
|
|
237 -- The following internal package defines the routines used for the
|
|
|
238 -- instantiation of a new System.HTable.Static_HTable (see below). See
|
|
|
239 -- spec in g-htable.ads for details of usage.
|
|
|
240
|
|
|
241 package HTable_Subprograms is
|
|
|
242 procedure Set_HT_Link (T : Tag; Next : Tag);
|
|
|
243 function Get_HT_Link (T : Tag) return Tag;
|
|
|
244 function Hash (F : System.Address) return HTable_Headers;
|
|
|
245 function Equal (A, B : System.Address) return Boolean;
|
|
|
246 end HTable_Subprograms;
|
|
|
247
|
|
|
248 package External_Tag_HTable is new System.HTable.Static_HTable (
|
|
|
249 Header_Num => HTable_Headers,
|
|
|
250 Element => Dispatch_Table,
|
|
|
251 Elmt_Ptr => Tag,
|
|
|
252 Null_Ptr => null,
|
|
|
253 Set_Next => HTable_Subprograms.Set_HT_Link,
|
|
|
254 Next => HTable_Subprograms.Get_HT_Link,
|
|
|
255 Key => System.Address,
|
|
|
256 Get_Key => Get_External_Tag,
|
|
|
257 Hash => HTable_Subprograms.Hash,
|
|
|
258 Equal => HTable_Subprograms.Equal);
|
|
|
259
|
|
|
260 ------------------------
|
|
|
261 -- HTable_Subprograms --
|
|
|
262 ------------------------
|
|
|
263
|
|
|
264 -- Bodies of routines for hash table instantiation
|
|
|
265
|
|
|
266 package body HTable_Subprograms is
|
|
|
267
|
|
|
268 -----------
|
|
|
269 -- Equal --
|
|
|
270 -----------
|
|
|
271
|
|
|
272 function Equal (A, B : System.Address) return Boolean is
|
|
|
273 Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
|
|
|
274 Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
|
|
|
275 J : Integer;
|
|
|
276 begin
|
|
|
277 J := 1;
|
|
|
278 loop
|
|
|
279 if Str1 (J) /= Str2 (J) then
|
|
|
280 return False;
|
|
|
281 elsif Str1 (J) = ASCII.NUL then
|
|
|
282 return True;
|
|
|
283 else
|
|
|
284 J := J + 1;
|
|
|
285 end if;
|
|
|
286 end loop;
|
|
|
287 end Equal;
|
|
|
288
|
|
|
289 -----------------
|
|
|
290 -- Get_HT_Link --
|
|
|
291 -----------------
|
|
|
292
|
|
|
293 function Get_HT_Link (T : Tag) return Tag is
|
|
|
294 TSD_Ptr : constant Addr_Ptr :=
|
|
|
295 To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
|
|
|
296 TSD : constant Type_Specific_Data_Ptr :=
|
|
|
297 To_Type_Specific_Data_Ptr (TSD_Ptr.all);
|
|
|
298 begin
|
|
|
299 return TSD.HT_Link.all;
|
|
|
300 end Get_HT_Link;
|
|
|
301
|
|
|
302 ----------
|
|
|
303 -- Hash --
|
|
|
304 ----------
|
|
|
305
|
|
|
306 function Hash (F : System.Address) return HTable_Headers is
|
|
|
307 function H is new System.HTable.Hash (HTable_Headers);
|
|
|
308 Str : constant Cstring_Ptr := To_Cstring_Ptr (F);
|
|
|
309 Res : constant HTable_Headers := H (Str (1 .. Length (Str)));
|
|
|
310 begin
|
|
|
311 return Res;
|
|
|
312 end Hash;
|
|
|
313
|
|
|
314 -----------------
|
|
|
315 -- Set_HT_Link --
|
|
|
316 -----------------
|
|
|
317
|
|
|
318 procedure Set_HT_Link (T : Tag; Next : Tag) is
|
|
|
319 TSD_Ptr : constant Addr_Ptr :=
|
|
|
320 To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
|
|
|
321 TSD : constant Type_Specific_Data_Ptr :=
|
|
|
322 To_Type_Specific_Data_Ptr (TSD_Ptr.all);
|
|
|
323 begin
|
|
|
324 TSD.HT_Link.all := Next;
|
|
|
325 end Set_HT_Link;
|
|
|
326
|
|
|
327 end HTable_Subprograms;
|
|
|
328
|
|
|
329 ------------------
|
|
|
330 -- Base_Address --
|
|
|
331 ------------------
|
|
|
332
|
|
|
333 function Base_Address (This : System.Address) return System.Address is
|
|
|
334 begin
|
|
|
335 return This - Offset_To_Top (This);
|
|
|
336 end Base_Address;
|
|
|
337
|
|
|
338 ---------------
|
|
|
339 -- Check_TSD --
|
|
|
340 ---------------
|
|
|
341
|
|
|
342 procedure Check_TSD (TSD : Type_Specific_Data_Ptr) is
|
|
|
343 T : Tag;
|
|
|
344
|
|
|
345 E_Tag_Len : constant Integer := Length (TSD.External_Tag);
|
|
|
346 E_Tag : String (1 .. E_Tag_Len);
|
|
|
347 for E_Tag'Address use TSD.External_Tag.all'Address;
|
|
|
348 pragma Import (Ada, E_Tag);
|
|
|
349
|
|
|
350 Dup_Ext_Tag : constant String := "duplicated external tag """;
|
|
|
351
|
|
|
352 begin
|
|
|
353 -- Verify that the external tag of this TSD is not registered in the
|
|
|
354 -- runtime hash table.
|
|
|
355
|
|
|
356 T := External_Tag_HTable.Get (To_Address (TSD.External_Tag));
|
|
|
357
|
|
|
358 if T /= null then
|
|
|
359
|
|
|
360 -- Avoid concatenation, as it is not allowed in no run time mode
|
|
|
361
|
|
|
362 declare
|
|
|
363 Msg : String (1 .. Dup_Ext_Tag'Length + E_Tag_Len + 1);
|
|
|
364 begin
|
|
|
365 Msg (1 .. Dup_Ext_Tag'Length) := Dup_Ext_Tag;
|
|
|
366 Msg (Dup_Ext_Tag'Length + 1 .. Dup_Ext_Tag'Length + E_Tag_Len) :=
|
|
|
367 E_Tag;
|
|
|
368 Msg (Msg'Last) := '"';
|
|
|
369 raise Program_Error with Msg;
|
|
|
370 end;
|
|
|
371 end if;
|
|
|
372 end Check_TSD;
|
|
|
373
|
|
|
374 --------------------
|
|
|
375 -- Descendant_Tag --
|
|
|
376 --------------------
|
|
|
377
|
|
|
378 function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
|
|
|
379 Int_Tag : constant Tag := Internal_Tag (External);
|
|
|
380 begin
|
|
|
381 if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
|
|
|
382 raise Tag_Error;
|
|
|
383 else
|
|
|
384 return Int_Tag;
|
|
|
385 end if;
|
|
|
386 end Descendant_Tag;
|
|
|
387
|
|
|
388 --------------
|
|
|
389 -- Displace --
|
|
|
390 --------------
|
|
|
391
|
|
|
392 function Displace (This : System.Address; T : Tag) return System.Address is
|
|
|
393 Iface_Table : Interface_Data_Ptr;
|
|
|
394 Obj_Base : System.Address;
|
|
|
395 Obj_DT : Dispatch_Table_Ptr;
|
|
|
396 Obj_DT_Tag : Tag;
|
|
|
397
|
|
|
398 begin
|
|
|
399 if System."=" (This, System.Null_Address) then
|
|
|
400 return System.Null_Address;
|
|
|
401 end if;
|
|
|
402
|
|
|
403 Obj_Base := Base_Address (This);
|
|
|
404 Obj_DT_Tag := To_Tag_Ptr (Obj_Base).all;
|
|
|
405 Obj_DT := DT (To_Tag_Ptr (Obj_Base).all);
|
|
|
406 Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table;
|
|
|
407
|
|
|
408 if Iface_Table /= null then
|
|
|
409 for Id in 1 .. Iface_Table.Nb_Ifaces loop
|
|
|
410 if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then
|
|
|
411
|
|
|
412 -- Case of Static value of Offset_To_Top
|
|
|
413
|
|
|
414 if Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top then
|
|
|
415 Obj_Base := Obj_Base +
|
|
|
416 Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value;
|
|
|
417
|
|
|
418 -- Otherwise call the function generated by the expander to
|
|
|
419 -- provide the value.
|
|
|
420
|
|
|
421 else
|
|
|
422 Obj_Base := Obj_Base +
|
|
|
423 Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func.all
|
|
|
424 (Obj_Base);
|
|
|
425 end if;
|
|
|
426
|
|
|
427 return Obj_Base;
|
|
|
428 end if;
|
|
|
429 end loop;
|
|
|
430 end if;
|
|
|
431
|
|
|
432 -- Check if T is an immediate ancestor. This is required to handle
|
|
|
433 -- conversion of class-wide interfaces to tagged types.
|
|
|
434
|
|
|
435 if CW_Membership (Obj_DT_Tag, T) then
|
|
|
436 return Obj_Base;
|
|
|
437 end if;
|
|
|
438
|
|
|
439 -- If the object does not implement the interface we must raise CE
|
|
|
440
|
|
|
441 raise Constraint_Error with "invalid interface conversion";
|
|
|
442 end Displace;
|
|
|
443
|
|
|
444 --------
|
|
|
445 -- DT --
|
|
|
446 --------
|
|
|
447
|
|
|
448 function DT (T : Tag) return Dispatch_Table_Ptr is
|
|
|
449 Offset : constant SSE.Storage_Offset :=
|
|
|
450 To_Dispatch_Table_Ptr (T).Prims_Ptr'Position;
|
|
|
451 begin
|
|
|
452 return To_Dispatch_Table_Ptr (To_Address (T) - Offset);
|
|
|
453 end DT;
|
|
|
454
|
|
|
455 -------------------
|
|
|
456 -- IW_Membership --
|
|
|
457 -------------------
|
|
|
458
|
|
|
459 function IW_Membership
|
|
|
460 (Descendant_TSD : Type_Specific_Data_Ptr;
|
|
|
461 T : Tag) return Boolean
|
|
|
462 is
|
|
|
463 Iface_Table : Interface_Data_Ptr;
|
|
|
464
|
|
|
465 begin
|
|
|
466 Iface_Table := Descendant_TSD.Interfaces_Table;
|
|
|
467
|
|
|
468 if Iface_Table /= null then
|
|
|
469 for Id in 1 .. Iface_Table.Nb_Ifaces loop
|
|
|
470 if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then
|
|
|
471 return True;
|
|
|
472 end if;
|
|
|
473 end loop;
|
|
|
474 end if;
|
|
|
475
|
|
|
476 -- Look for the tag in the ancestor tags table. This is required for:
|
|
|
477 -- Iface_CW in Typ'Class
|
|
|
478
|
|
|
479 for Id in 0 .. Descendant_TSD.Idepth loop
|
|
|
480 if Descendant_TSD.Tags_Table (Id) = T then
|
|
|
481 return True;
|
|
|
482 end if;
|
|
|
483 end loop;
|
|
|
484
|
|
|
485 return False;
|
|
|
486 end IW_Membership;
|
|
|
487
|
|
|
488 -------------------
|
|
|
489 -- IW_Membership --
|
|
|
490 -------------------
|
|
|
491
|
|
|
492 -- Canonical implementation of Classwide Membership corresponding to:
|
|
|
493
|
|
|
494 -- Obj in Iface'Class
|
|
|
495
|
|
|
496 -- Each dispatch table contains a table with the tags of all the
|
|
|
497 -- implemented interfaces.
|
|
|
498
|
|
|
499 -- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
|
|
|
500 -- that are contained in the dispatch table referenced by Obj'Tag.
|
|
|
501
|
|
|
502 function IW_Membership (This : System.Address; T : Tag) return Boolean is
|
|
|
503 Obj_Base : System.Address;
|
|
|
504 Obj_DT : Dispatch_Table_Ptr;
|
|
|
505 Obj_TSD : Type_Specific_Data_Ptr;
|
|
|
506
|
|
|
507 begin
|
|
|
508 Obj_Base := Base_Address (This);
|
|
|
509 Obj_DT := DT (To_Tag_Ptr (Obj_Base).all);
|
|
|
510 Obj_TSD := To_Type_Specific_Data_Ptr (Obj_DT.TSD);
|
|
|
511
|
|
|
512 return IW_Membership (Obj_TSD, T);
|
|
|
513 end IW_Membership;
|
|
|
514
|
|
|
515 -------------------
|
|
|
516 -- Expanded_Name --
|
|
|
517 -------------------
|
|
|
518
|
|
|
519 function Expanded_Name (T : Tag) return String is
|
|
|
520 Result : Cstring_Ptr;
|
|
|
521 TSD_Ptr : Addr_Ptr;
|
|
|
522 TSD : Type_Specific_Data_Ptr;
|
|
|
523
|
|
|
524 begin
|
|
|
525 if T = No_Tag then
|
|
|
526 raise Tag_Error;
|
|
|
527 end if;
|
|
|
528
|
|
|
529 TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
|
|
|
530 TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
|
|
|
531 Result := TSD.Expanded_Name;
|
|
|
532 return Result (1 .. Length (Result));
|
|
|
533 end Expanded_Name;
|
|
|
534
|
|
|
535 ------------------
|
|
|
536 -- External_Tag --
|
|
|
537 ------------------
|
|
|
538
|
|
|
539 function External_Tag (T : Tag) return String is
|
|
|
540 Result : Cstring_Ptr;
|
|
|
541 TSD_Ptr : Addr_Ptr;
|
|
|
542 TSD : Type_Specific_Data_Ptr;
|
|
|
543
|
|
|
544 begin
|
|
|
545 if T = No_Tag then
|
|
|
546 raise Tag_Error;
|
|
|
547 end if;
|
|
|
548
|
|
|
549 TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
|
|
|
550 TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
|
|
|
551 Result := TSD.External_Tag;
|
|
|
552 return Result (1 .. Length (Result));
|
|
|
553 end External_Tag;
|
|
|
554
|
|
|
555 ---------------------
|
|
|
556 -- Get_Entry_Index --
|
|
|
557 ---------------------
|
|
|
558
|
|
|
559 function Get_Entry_Index (T : Tag; Position : Positive) return Positive is
|
|
|
560 begin
|
|
|
561 return SSD (T).SSD_Table (Position).Index;
|
|
|
562 end Get_Entry_Index;
|
|
|
563
|
|
|
564 ----------------------
|
|
|
565 -- Get_Prim_Op_Kind --
|
|
|
566 ----------------------
|
|
|
567
|
|
|
568 function Get_Prim_Op_Kind
|
|
|
569 (T : Tag;
|
|
|
570 Position : Positive) return Prim_Op_Kind
|
|
|
571 is
|
|
|
572 begin
|
|
|
573 return SSD (T).SSD_Table (Position).Kind;
|
|
|
574 end Get_Prim_Op_Kind;
|
|
|
575
|
|
|
576 ----------------------
|
|
|
577 -- Get_Offset_Index --
|
|
|
578 ----------------------
|
|
|
579
|
|
|
580 function Get_Offset_Index
|
|
|
581 (T : Tag;
|
|
|
582 Position : Positive) return Positive
|
|
|
583 is
|
|
|
584 begin
|
|
|
585 if Is_Primary_DT (T) then
|
|
|
586 return Position;
|
|
|
587 else
|
|
|
588 return OSD (T).OSD_Table (Position);
|
|
|
589 end if;
|
|
|
590 end Get_Offset_Index;
|
|
|
591
|
|
|
592 ---------------------
|
|
|
593 -- Get_Tagged_Kind --
|
|
|
594 ---------------------
|
|
|
595
|
|
|
596 function Get_Tagged_Kind (T : Tag) return Tagged_Kind is
|
|
|
597 begin
|
|
|
598 return DT (T).Tag_Kind;
|
|
|
599 end Get_Tagged_Kind;
|
|
|
600
|
|
|
601 -----------------------------
|
|
|
602 -- Interface_Ancestor_Tags --
|
|
|
603 -----------------------------
|
|
|
604
|
|
|
605 function Interface_Ancestor_Tags (T : Tag) return Tag_Array is
|
|
|
606 TSD_Ptr : constant Addr_Ptr :=
|
|
|
607 To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
|
|
|
608 TSD : constant Type_Specific_Data_Ptr :=
|
|
|
609 To_Type_Specific_Data_Ptr (TSD_Ptr.all);
|
|
|
610 Iface_Table : constant Interface_Data_Ptr := TSD.Interfaces_Table;
|
|
|
611
|
|
|
612 begin
|
|
|
613 if Iface_Table = null then
|
|
|
614 declare
|
|
|
615 Table : Tag_Array (1 .. 0);
|
|
|
616 begin
|
|
|
617 return Table;
|
|
|
618 end;
|
|
|
619
|
|
|
620 else
|
|
|
621 declare
|
|
|
622 Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces);
|
|
|
623 begin
|
|
|
624 for J in 1 .. Iface_Table.Nb_Ifaces loop
|
|
|
625 Table (J) := Iface_Table.Ifaces_Table (J).Iface_Tag;
|
|
|
626 end loop;
|
|
|
627
|
|
|
628 return Table;
|
|
|
629 end;
|
|
|
630 end if;
|
|
|
631 end Interface_Ancestor_Tags;
|
|
|
632
|
|
|
633 ------------------
|
|
|
634 -- Internal_Tag --
|
|
|
635 ------------------
|
|
|
636
|
|
|
637 -- Internal tags have the following format:
|
|
|
638 -- "Internal tag at 16#ADDRESS#: <full-name-of-tagged-type>"
|
|
|
639
|
|
|
640 Internal_Tag_Header : constant String := "Internal tag at ";
|
|
|
641 Header_Separator : constant Character := '#';
|
|
|
642
|
|
|
643 function Internal_Tag (External : String) return Tag is
|
|
|
644 pragma Unsuppress (All_Checks);
|
|
|
645 -- To make T'Class'Input robust in the case of bad data
|
|
|
646
|
|
|
647 Res : Tag := null;
|
|
|
648
|
|
|
649 begin
|
|
|
650 -- Raise Tag_Error for empty strings and very long strings. This makes
|
|
|
651 -- T'Class'Input robust in the case of bad data, for example
|
|
|
652 --
|
|
|
653 -- String (123456789..1234)
|
|
|
654 --
|
|
|
655 -- The limit of 10,000 characters is arbitrary, but is unlikely to be
|
|
|
656 -- exceeded by legitimate external tag names.
|
|
|
657
|
|
|
658 if External'Length not in 1 .. 10_000 then
|
|
|
659 raise Tag_Error;
|
|
|
660 end if;
|
|
|
661
|
|
|
662 -- Handle locally defined tagged types
|
|
|
663
|
|
|
664 if External'Length > Internal_Tag_Header'Length
|
|
|
665 and then
|
|
|
666 External (External'First ..
|
|
|
667 External'First + Internal_Tag_Header'Length - 1) =
|
|
|
668 Internal_Tag_Header
|
|
|
669 then
|
|
|
670 declare
|
|
|
671 Addr_First : constant Natural :=
|
|
|
672 External'First + Internal_Tag_Header'Length;
|
|
|
673 Addr_Last : Natural;
|
|
|
674 Addr : Integer_Address;
|
|
|
675
|
|
|
676 begin
|
|
|
677 -- Search the second separator (#) to identify the address
|
|
|
678
|
|
|
679 Addr_Last := Addr_First;
|
|
|
680
|
|
|
681 for J in 1 .. 2 loop
|
|
|
682 while Addr_Last <= External'Last
|
|
|
683 and then External (Addr_Last) /= Header_Separator
|
|
|
684 loop
|
|
|
685 Addr_Last := Addr_Last + 1;
|
|
|
686 end loop;
|
|
|
687
|
|
|
688 -- Skip the first separator
|
|
|
689
|
|
|
690 if J = 1 then
|
|
|
691 Addr_Last := Addr_Last + 1;
|
|
|
692 end if;
|
|
|
693 end loop;
|
|
|
694
|
|
|
695 if Addr_Last <= External'Last then
|
|
|
696
|
|
|
697 -- Protect the run-time against wrong internal tags. We
|
|
|
698 -- cannot use exception handlers here because it would
|
|
|
699 -- disable the use of this run-time compiling with
|
|
|
700 -- restriction No_Exception_Handler.
|
|
|
701
|
|
|
702 declare
|
|
|
703 C : Character;
|
|
|
704 Wrong_Tag : Boolean := False;
|
|
|
705
|
|
|
706 begin
|
|
|
707 if External (Addr_First) /= '1'
|
|
|
708 or else External (Addr_First + 1) /= '6'
|
|
|
709 or else External (Addr_First + 2) /= '#'
|
|
|
710 then
|
|
|
711 Wrong_Tag := True;
|
|
|
712
|
|
|
713 else
|
|
|
714 for J in Addr_First + 3 .. Addr_Last - 1 loop
|
|
|
715 C := External (J);
|
|
|
716
|
|
|
717 if not (C in '0' .. '9')
|
|
|
718 and then not (C in 'A' .. 'F')
|
|
|
719 and then not (C in 'a' .. 'f')
|
|
|
720 then
|
|
|
721 Wrong_Tag := True;
|
|
|
722 exit;
|
|
|
723 end if;
|
|
|
724 end loop;
|
|
|
725 end if;
|
|
|
726
|
|
|
727 -- Convert the numeric value into a tag
|
|
|
728
|
|
|
729 if not Wrong_Tag then
|
|
|
730 Addr := Integer_Address'Value
|
|
|
731 (External (Addr_First .. Addr_Last));
|
|
|
732
|
|
|
733 -- Internal tags never have value 0
|
|
|
734
|
|
|
735 if Addr /= 0 then
|
|
|
736 return To_Tag (Addr);
|
|
|
737 end if;
|
|
|
738 end if;
|
|
|
739 end;
|
|
|
740 end if;
|
|
|
741 end;
|
|
|
742
|
|
|
743 -- Handle library-level tagged types
|
|
|
744
|
|
|
745 else
|
|
|
746 -- Make NUL-terminated copy of external tag string
|
|
|
747
|
|
|
748 declare
|
|
|
749 Ext_Copy : aliased String (External'First .. External'Last + 1);
|
|
|
750 pragma Assert (Ext_Copy'Length > 1); -- See Length check at top
|
|
|
751 begin
|
|
|
752 Ext_Copy (External'Range) := External;
|
|
|
753 Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
|
|
|
754 Res := External_Tag_HTable.Get (Ext_Copy'Address);
|
|
|
755 end;
|
|
|
756 end if;
|
|
|
757
|
|
|
758 if Res = null then
|
|
|
759 declare
|
|
|
760 Msg1 : constant String := "unknown tagged type: ";
|
|
|
761 Msg2 : String (1 .. Msg1'Length + External'Length);
|
|
|
762
|
|
|
763 begin
|
|
|
764 Msg2 (1 .. Msg1'Length) := Msg1;
|
|
|
765 Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
|
|
|
766 External;
|
|
|
767 Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2);
|
|
|
768 end;
|
|
|
769 end if;
|
|
|
770
|
|
|
771 return Res;
|
|
|
772 end Internal_Tag;
|
|
|
773
|
|
|
774 ---------------------------------
|
|
|
775 -- Is_Descendant_At_Same_Level --
|
|
|
776 ---------------------------------
|
|
|
777
|
|
|
778 function Is_Descendant_At_Same_Level
|
|
|
779 (Descendant : Tag;
|
|
|
780 Ancestor : Tag) return Boolean
|
|
|
781 is
|
|
|
782 begin
|
|
|
783 if Descendant = Ancestor then
|
|
|
784 return True;
|
|
|
785
|
|
|
786 else
|
|
|
787 declare
|
|
|
788 D_TSD_Ptr : constant Addr_Ptr :=
|
|
|
789 To_Addr_Ptr (To_Address (Descendant) - DT_Typeinfo_Ptr_Size);
|
|
|
790 A_TSD_Ptr : constant Addr_Ptr :=
|
|
|
791 To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size);
|
|
|
792 D_TSD : constant Type_Specific_Data_Ptr :=
|
|
|
793 To_Type_Specific_Data_Ptr (D_TSD_Ptr.all);
|
|
|
794 A_TSD : constant Type_Specific_Data_Ptr :=
|
|
|
795 To_Type_Specific_Data_Ptr (A_TSD_Ptr.all);
|
|
|
796 begin
|
|
|
797 return
|
|
|
798 D_TSD.Access_Level = A_TSD.Access_Level
|
|
|
799 and then (CW_Membership (Descendant, Ancestor)
|
|
|
800 or else IW_Membership (D_TSD, Ancestor));
|
|
|
801 end;
|
|
|
802 end if;
|
|
|
803 end Is_Descendant_At_Same_Level;
|
|
|
804
|
|
|
805 ------------
|
|
|
806 -- Length --
|
|
|
807 ------------
|
|
|
808
|
|
|
809 -- Note: This unit is used in the Ravenscar runtime library, so it cannot
|
|
|
810 -- depend on System.CTRL. Furthermore, this happens on CPUs where the GCC
|
|
|
811 -- intrinsic strlen may not be available, so we need to recode our own Ada
|
|
|
812 -- version here.
|
|
|
813
|
|
|
814 function Length (Str : Cstring_Ptr) return Natural is
|
|
|
815 Len : Integer;
|
|
|
816
|
|
|
817 begin
|
|
|
818 Len := 1;
|
|
|
819 while Str (Len) /= ASCII.NUL loop
|
|
|
820 Len := Len + 1;
|
|
|
821 end loop;
|
|
|
822
|
|
|
823 return Len - 1;
|
|
|
824 end Length;
|
|
|
825
|
|
|
826 -------------------
|
|
|
827 -- Offset_To_Top --
|
|
|
828 -------------------
|
|
|
829
|
|
|
830 function Offset_To_Top
|
|
|
831 (This : System.Address) return SSE.Storage_Offset
|
|
|
832 is
|
|
|
833 Tag_Size : constant SSE.Storage_Count :=
|
|
|
834 SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit));
|
|
|
835
|
|
|
836 type Storage_Offset_Ptr is access SSE.Storage_Offset;
|
|
|
837 function To_Storage_Offset_Ptr is
|
|
|
838 new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
|
|
|
839
|
|
|
840 Curr_DT : Dispatch_Table_Ptr;
|
|
|
841
|
|
|
842 begin
|
|
|
843 Curr_DT := DT (To_Tag_Ptr (This).all);
|
|
|
844
|
|
|
845 -- See the documentation of Dispatch_Table_Wrapper.Offset_To_Top
|
|
|
846
|
|
|
847 if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then
|
|
|
848
|
|
|
849 -- The parent record type has variable-size components, so the
|
|
|
850 -- instance-specific offset is stored in the tagged record, right
|
|
|
851 -- after the reference to Curr_DT (which is a secondary dispatch
|
|
|
852 -- table).
|
|
|
853
|
|
|
854 return To_Storage_Offset_Ptr (This + Tag_Size).all;
|
|
|
855
|
|
|
856 else
|
|
|
857 -- The offset is compile-time known, so it is simply stored in the
|
|
|
858 -- Offset_To_Top field.
|
|
|
859
|
|
|
860 return Curr_DT.Offset_To_Top;
|
|
|
861 end if;
|
|
|
862 end Offset_To_Top;
|
|
|
863
|
|
|
864 ------------------------
|
|
|
865 -- Needs_Finalization --
|
|
|
866 ------------------------
|
|
|
867
|
|
|
868 function Needs_Finalization (T : Tag) return Boolean is
|
|
|
869 TSD_Ptr : constant Addr_Ptr :=
|
|
|
870 To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
|
|
|
871 TSD : constant Type_Specific_Data_Ptr :=
|
|
|
872 To_Type_Specific_Data_Ptr (TSD_Ptr.all);
|
|
|
873 begin
|
|
|
874 return TSD.Needs_Finalization;
|
|
|
875 end Needs_Finalization;
|
|
|
876
|
|
|
877 -----------------
|
|
|
878 -- Parent_Size --
|
|
|
879 -----------------
|
|
|
880
|
|
|
881 function Parent_Size
|
|
|
882 (Obj : System.Address;
|
|
|
883 T : Tag) return SSE.Storage_Count
|
|
|
884 is
|
|
|
885 Parent_Slot : constant Positive := 1;
|
|
|
886 -- The tag of the parent is always in the first slot of the table of
|
|
|
887 -- ancestor tags.
|
|
|
888
|
|
|
889 TSD_Ptr : constant Addr_Ptr :=
|
|
|
890 To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
|
|
|
891 TSD : constant Type_Specific_Data_Ptr :=
|
|
|
892 To_Type_Specific_Data_Ptr (TSD_Ptr.all);
|
|
|
893 -- Pointer to the TSD
|
|
|
894
|
|
|
895 Parent_Tag : constant Tag := TSD.Tags_Table (Parent_Slot);
|
|
|
896 Parent_TSD_Ptr : constant Addr_Ptr :=
|
|
|
897 To_Addr_Ptr (To_Address (Parent_Tag) - DT_Typeinfo_Ptr_Size);
|
|
|
898 Parent_TSD : constant Type_Specific_Data_Ptr :=
|
|
|
899 To_Type_Specific_Data_Ptr (Parent_TSD_Ptr.all);
|
|
|
900
|
|
|
901 begin
|
|
|
902 -- Here we compute the size of the _parent field of the object
|
|
|
903
|
|
|
904 return SSE.Storage_Count (Parent_TSD.Size_Func.all (Obj));
|
|
|
905 end Parent_Size;
|
|
|
906
|
|
|
907 ----------------
|
|
|
908 -- Parent_Tag --
|
|
|
909 ----------------
|
|
|
910
|
|
|
911 function Parent_Tag (T : Tag) return Tag is
|
|
|
912 TSD_Ptr : Addr_Ptr;
|
|
|
913 TSD : Type_Specific_Data_Ptr;
|
|
|
914
|
|
|
915 begin
|
|
|
916 if T = No_Tag then
|
|
|
917 raise Tag_Error;
|
|
|
918 end if;
|
|
|
919
|
|
|
920 TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
|
|
|
921 TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
|
|
|
922
|
|
|
923 -- The Parent_Tag of a root-level tagged type is defined to be No_Tag.
|
|
|
924 -- The first entry in the Ancestors_Tags array will be null for such
|
|
|
925 -- a type, but it's better to be explicit about returning No_Tag in
|
|
|
926 -- this case.
|
|
|
927
|
|
|
928 if TSD.Idepth = 0 then
|
|
|
929 return No_Tag;
|
|
|
930 else
|
|
|
931 return TSD.Tags_Table (1);
|
|
|
932 end if;
|
|
|
933 end Parent_Tag;
|
|
|
934
|
|
|
935 -------------------------------
|
|
|
936 -- Register_Interface_Offset --
|
|
|
937 -------------------------------
|
|
|
938
|
|
|
939 procedure Register_Interface_Offset
|
|
|
940 (Prim_T : Tag;
|
|
|
941 Interface_T : Tag;
|
|
|
942 Is_Static : Boolean;
|
|
|
943 Offset_Value : SSE.Storage_Offset;
|
|
|
944 Offset_Func : Offset_To_Top_Function_Ptr)
|
|
|
945 is
|
|
|
946 Prim_DT : constant Dispatch_Table_Ptr := DT (Prim_T);
|
|
|
947 Iface_Table : constant Interface_Data_Ptr :=
|
|
|
948 To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
|
|
|
949
|
|
|
950 begin
|
|
|
951 -- Save Offset_Value in the table of interfaces of the primary DT.
|
|
|
952 -- This data will be used by the subprogram "Displace" to give support
|
|
|
953 -- to backward abstract interface type conversions.
|
|
|
954
|
|
|
955 -- Register the offset in the table of interfaces
|
|
|
956
|
|
|
957 if Iface_Table /= null then
|
|
|
958 for Id in 1 .. Iface_Table.Nb_Ifaces loop
|
|
|
959 if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then
|
|
|
960 if Is_Static or else Offset_Value = 0 then
|
|
|
961 Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := True;
|
|
|
962 Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value :=
|
|
|
963 Offset_Value;
|
|
|
964 else
|
|
|
965 Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False;
|
|
|
966 Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func :=
|
|
|
967 Offset_Func;
|
|
|
968 end if;
|
|
|
969
|
|
|
970 return;
|
|
|
971 end if;
|
|
|
972 end loop;
|
|
|
973 end if;
|
|
|
974
|
|
|
975 -- If we arrive here there is some error in the run-time data structure
|
|
|
976
|
|
|
977 raise Program_Error;
|
|
|
978 end Register_Interface_Offset;
|
|
|
979
|
|
|
980 ------------------
|
|
|
981 -- Register_Tag --
|
|
|
982 ------------------
|
|
|
983
|
|
|
984 procedure Register_Tag (T : Tag) is
|
|
|
985 begin
|
|
|
986 External_Tag_HTable.Set (T);
|
|
|
987 end Register_Tag;
|
|
|
988
|
|
|
989 -------------------
|
|
|
990 -- Secondary_Tag --
|
|
|
991 -------------------
|
|
|
992
|
|
|
993 function Secondary_Tag (T, Iface : Tag) return Tag is
|
|
|
994 Iface_Table : Interface_Data_Ptr;
|
|
|
995 Obj_DT : Dispatch_Table_Ptr;
|
|
|
996
|
|
|
997 begin
|
|
|
998 if not Is_Primary_DT (T) then
|
|
|
999 raise Program_Error;
|
|
|
1000 end if;
|
|
|
1001
|
|
|
1002 Obj_DT := DT (T);
|
|
|
1003 Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table;
|
|
|
1004
|
|
|
1005 if Iface_Table /= null then
|
|
|
1006 for Id in 1 .. Iface_Table.Nb_Ifaces loop
|
|
|
1007 if Iface_Table.Ifaces_Table (Id).Iface_Tag = Iface then
|
|
|
1008 return Iface_Table.Ifaces_Table (Id).Secondary_DT;
|
|
|
1009 end if;
|
|
|
1010 end loop;
|
|
|
1011 end if;
|
|
|
1012
|
|
|
1013 -- If the object does not implement the interface we must raise CE
|
|
|
1014
|
|
|
1015 raise Constraint_Error with "invalid interface conversion";
|
|
|
1016 end Secondary_Tag;
|
|
|
1017
|
|
|
1018 ---------------------
|
|
|
1019 -- Set_Entry_Index --
|
|
|
1020 ---------------------
|
|
|
1021
|
|
|
1022 procedure Set_Entry_Index
|
|
|
1023 (T : Tag;
|
|
|
1024 Position : Positive;
|
|
|
1025 Value : Positive)
|
|
|
1026 is
|
|
|
1027 begin
|
|
|
1028 SSD (T).SSD_Table (Position).Index := Value;
|
|
|
1029 end Set_Entry_Index;
|
|
|
1030
|
|
|
1031 -----------------------
|
|
|
1032 -- Set_Offset_To_Top --
|
|
|
1033 -----------------------
|
|
|
1034
|
|
|
1035 procedure Set_Dynamic_Offset_To_Top
|
|
|
1036 (This : System.Address;
|
|
|
1037 Prim_T : Tag;
|
|
|
1038 Interface_T : Tag;
|
|
|
1039 Offset_Value : SSE.Storage_Offset;
|
|
|
1040 Offset_Func : Offset_To_Top_Function_Ptr)
|
|
|
1041 is
|
|
|
1042 Sec_Base : System.Address;
|
|
|
1043 Sec_DT : Dispatch_Table_Ptr;
|
|
|
1044
|
|
|
1045 begin
|
|
|
1046 -- Save the offset to top field in the secondary dispatch table
|
|
|
1047
|
|
|
1048 if Offset_Value /= 0 then
|
|
|
1049 Sec_Base := This + Offset_Value;
|
|
|
1050 Sec_DT := DT (To_Tag_Ptr (Sec_Base).all);
|
|
|
1051 Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last;
|
|
|
1052 end if;
|
|
|
1053
|
|
|
1054 Register_Interface_Offset
|
|
|
1055 (Prim_T, Interface_T, False, Offset_Value, Offset_Func);
|
|
|
1056 end Set_Dynamic_Offset_To_Top;
|
|
|
1057
|
|
|
1058 ----------------------
|
|
|
1059 -- Set_Prim_Op_Kind --
|
|
|
1060 ----------------------
|
|
|
1061
|
|
|
1062 procedure Set_Prim_Op_Kind
|
|
|
1063 (T : Tag;
|
|
|
1064 Position : Positive;
|
|
|
1065 Value : Prim_Op_Kind)
|
|
|
1066 is
|
|
|
1067 begin
|
|
|
1068 SSD (T).SSD_Table (Position).Kind := Value;
|
|
|
1069 end Set_Prim_Op_Kind;
|
|
|
1070
|
|
|
1071 --------------------
|
|
|
1072 -- Unregister_Tag --
|
|
|
1073 --------------------
|
|
|
1074
|
|
|
1075 procedure Unregister_Tag (T : Tag) is
|
|
|
1076 begin
|
|
|
1077 External_Tag_HTable.Remove (Get_External_Tag (T));
|
|
|
1078 end Unregister_Tag;
|
|
|
1079
|
|
|
1080 ------------------------
|
|
|
1081 -- Wide_Expanded_Name --
|
|
|
1082 ------------------------
|
|
|
1083
|
|
|
1084 WC_Encoding : Character;
|
|
|
1085 pragma Import (C, WC_Encoding, "__gl_wc_encoding");
|
|
|
1086 -- Encoding method for source, as exported by binder
|
|
|
1087
|
|
|
1088 function Wide_Expanded_Name (T : Tag) return Wide_String is
|
|
|
1089 S : constant String := Expanded_Name (T);
|
|
|
1090 W : Wide_String (1 .. S'Length);
|
|
|
1091 L : Natural;
|
|
|
1092 begin
|
|
|
1093 String_To_Wide_String
|
|
|
1094 (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
|
|
|
1095 return W (1 .. L);
|
|
|
1096 end Wide_Expanded_Name;
|
|
|
1097
|
|
|
1098 -----------------------------
|
|
|
1099 -- Wide_Wide_Expanded_Name --
|
|
|
1100 -----------------------------
|
|
|
1101
|
|
|
1102 function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is
|
|
|
1103 S : constant String := Expanded_Name (T);
|
|
|
1104 W : Wide_Wide_String (1 .. S'Length);
|
|
|
1105 L : Natural;
|
|
|
1106 begin
|
|
|
1107 String_To_Wide_Wide_String
|
|
|
1108 (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
|
|
|
1109 return W (1 .. L);
|
|
|
1110 end Wide_Wide_Expanded_Name;
|
|
|
1111
|
|
|
1112 end Ada.Tags;
|
