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