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