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-2018, 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; 33with Ada.Unchecked_Conversion; 34 35with System.HTable; 36with System.Storage_Elements; use System.Storage_Elements; 37with System.WCh_Con; use System.WCh_Con; 38with System.WCh_StW; use System.WCh_StW; 39 40pragma 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 46package 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 1112end Ada.Tags; 1113