Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/a-tags.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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;