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