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