1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ D B U G -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1996-2021, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Alloc; 27with Atree; use Atree; 28with Debug; use Debug; 29with Einfo; use Einfo; 30with Einfo.Entities; use Einfo.Entities; 31with Einfo.Utils; use Einfo.Utils; 32with Exp_Util; use Exp_Util; 33with Nlists; use Nlists; 34with Nmake; use Nmake; 35with Opt; use Opt; 36with Output; use Output; 37with Sem_Aux; use Sem_Aux; 38with Sem_Eval; use Sem_Eval; 39with Sem_Util; use Sem_Util; 40with Sinfo; use Sinfo; 41with Sinfo.Nodes; use Sinfo.Nodes; 42with Sinfo.Utils; use Sinfo.Utils; 43with Stand; use Stand; 44with Stringt; use Stringt; 45with Table; 46with Tbuild; use Tbuild; 47with Urealp; use Urealp; 48 49package body Exp_Dbug is 50 51 -- The following table is used to queue up the entities passed as 52 -- arguments to Qualify_Entity_Names for later processing when 53 -- Qualify_All_Entity_Names is called. 54 55 package Name_Qualify_Units is new Table.Table ( 56 Table_Component_Type => Node_Id, 57 Table_Index_Type => Nat, 58 Table_Low_Bound => 1, 59 Table_Initial => Alloc.Name_Qualify_Units_Initial, 60 Table_Increment => Alloc.Name_Qualify_Units_Increment, 61 Table_Name => "Name_Qualify_Units"); 62 63 -------------------------------- 64 -- Use of Qualification Flags -- 65 -------------------------------- 66 67 -- There are two flags used to keep track of qualification of entities 68 69 -- Has_Fully_Qualified_Name 70 -- Has_Qualified_Name 71 72 -- The difference between these is as follows. Has_Qualified_Name is 73 -- set to indicate that the name has been qualified as required by the 74 -- spec of this package. As described there, this may involve the full 75 -- qualification for the name, but for some entities, notably procedure 76 -- local variables, this full qualification is not required. 77 78 -- The flag Has_Fully_Qualified_Name is set if indeed the name has been 79 -- fully qualified in the Ada sense. If Has_Fully_Qualified_Name is set, 80 -- then Has_Qualified_Name is also set, but the other way round is not 81 -- the case. 82 83 -- Consider the following example: 84 85 -- with ... 86 -- procedure X is 87 -- B : Ddd.Ttt; 88 -- procedure Y is .. 89 90 -- Here B is a procedure local variable, so it does not need fully 91 -- qualification. The flag Has_Qualified_Name will be set on the 92 -- first attempt to qualify B, to indicate that the job is done 93 -- and need not be redone. 94 95 -- But Y is qualified as x__y, since procedures are always fully 96 -- qualified, so the first time that an attempt is made to qualify 97 -- the name y, it will be replaced by x__y, and both flags are set. 98 99 -- Why the two flags? Well there are cases where we derive type names 100 -- from object names. As noted in the spec, type names are always 101 -- fully qualified. Suppose for example that the backend has to build 102 -- a padded type for variable B. then it will construct the PAD name 103 -- from B, but it requires full qualification, so the fully qualified 104 -- type name will be x__b___PAD. The two flags allow the circuit for 105 -- building this name to realize efficiently that b needs further 106 -- qualification. 107 108 -------------------- 109 -- Homonym_Suffix -- 110 -------------------- 111 112 -- The string defined here (and its associated length) is used to gather 113 -- the homonym string that will be appended to Name_Buffer when the name 114 -- is complete. Strip_Suffixes appends to this string as does 115 -- Append_Homonym_Number, and Output_Homonym_Numbers_Suffix appends the 116 -- string to the end of Name_Buffer. 117 118 Homonym_Numbers : String (1 .. 256); 119 Homonym_Len : Natural := 0; 120 121 ---------------------- 122 -- Local Procedures -- 123 ---------------------- 124 125 procedure Add_Uint_To_Buffer (U : Uint); 126 -- Add image of universal integer to Name_Buffer, updating Name_Len 127 128 procedure Add_Real_To_Buffer (U : Ureal); 129 -- Add nnn_ddd to Name_Buffer, where nnn and ddd are integer values of 130 -- the normalized numerator and denominator of the given real value. 131 132 procedure Append_Homonym_Number (E : Entity_Id); 133 -- If the entity E has homonyms in the same scope, then make an entry 134 -- in the Homonym_Numbers array, bumping Homonym_Count accordingly. 135 136 function Bounds_Match_Size (E : Entity_Id) return Boolean; 137 -- Determine whether the bounds of E match the size of the type. This is 138 -- used to determine whether encoding is required for a discrete type. 139 140 procedure Output_Homonym_Numbers_Suffix; 141 -- If homonym numbers are stored, then output them into Name_Buffer 142 143 procedure Prepend_String_To_Buffer (S : String); 144 -- Prepend given string to the contents of the string buffer, updating 145 -- the value in Name_Len (i.e. string is added at start of buffer). 146 147 procedure Prepend_Uint_To_Buffer (U : Uint); 148 -- Prepend image of universal integer to Name_Buffer, updating Name_Len 149 150 procedure Qualify_Entity_Name (Ent : Entity_Id); 151 -- If not already done, replaces the Chars field of the given entity 152 -- with the appropriate fully qualified name. 153 154 procedure Reset_Buffers; 155 -- Reset the contents of Name_Buffer and Homonym_Numbers by setting their 156 -- respective lengths to zero. 157 158 procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean); 159 -- Given an qualified entity name in Name_Buffer, remove any plain X or 160 -- X{nb} qualification suffix. The contents of Name_Buffer is not changed 161 -- but Name_Len may be adjusted on return to remove the suffix. If a 162 -- BNPE suffix is found and stripped, then BNPE_Suffix_Found is set to 163 -- True. If no suffix is found, then BNPE_Suffix_Found is not modified. 164 -- This routine also searches for a homonym suffix, and if one is found 165 -- it is also stripped, and the entries are added to the global homonym 166 -- list (Homonym_Numbers) so that they can later be put back. 167 168 ------------------------ 169 -- Add_Real_To_Buffer -- 170 ------------------------ 171 172 procedure Add_Real_To_Buffer (U : Ureal) is 173 begin 174 Add_Uint_To_Buffer (Norm_Num (U)); 175 Add_Str_To_Name_Buffer ("_"); 176 Add_Uint_To_Buffer (Norm_Den (U)); 177 end Add_Real_To_Buffer; 178 179 ------------------------ 180 -- Add_Uint_To_Buffer -- 181 ------------------------ 182 183 procedure Add_Uint_To_Buffer (U : Uint) is 184 begin 185 if U < 0 then 186 Add_Uint_To_Buffer (-U); 187 Add_Char_To_Name_Buffer ('m'); 188 else 189 UI_Image (U, Decimal); 190 Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length)); 191 end if; 192 end Add_Uint_To_Buffer; 193 194 --------------------------- 195 -- Append_Homonym_Number -- 196 --------------------------- 197 198 procedure Append_Homonym_Number (E : Entity_Id) is 199 200 procedure Add_Nat_To_H (Nr : Nat); 201 -- Little procedure to append Nr to Homonym_Numbers 202 203 ------------------ 204 -- Add_Nat_To_H -- 205 ------------------ 206 207 procedure Add_Nat_To_H (Nr : Nat) is 208 begin 209 if Nr >= 10 then 210 Add_Nat_To_H (Nr / 10); 211 end if; 212 213 Homonym_Len := Homonym_Len + 1; 214 Homonym_Numbers (Homonym_Len) := 215 Character'Val (Nr mod 10 + Character'Pos ('0')); 216 end Add_Nat_To_H; 217 218 -- Start of processing for Append_Homonym_Number 219 220 begin 221 if Has_Homonym (E) then 222 if Homonym_Len > 0 then 223 Homonym_Len := Homonym_Len + 1; 224 Homonym_Numbers (Homonym_Len) := '_'; 225 end if; 226 227 Add_Nat_To_H (Homonym_Number (E)); 228 end if; 229 end Append_Homonym_Number; 230 231 ----------------------- 232 -- Bounds_Match_Size -- 233 ----------------------- 234 235 function Bounds_Match_Size (E : Entity_Id) return Boolean is 236 Siz : Uint; 237 238 begin 239 if not Is_OK_Static_Subtype (E) then 240 return False; 241 242 elsif Is_Integer_Type (E) 243 and then Subtypes_Statically_Match (E, Base_Type (E)) 244 then 245 return True; 246 247 -- Here we check if the static bounds match the natural size, which is 248 -- the size passed through with the debugging information. This is the 249 -- Esize rounded up to 8, 16, 32, 64 or 128 as appropriate. 250 251 else 252 declare 253 Umark : constant Uintp.Save_Mark := Uintp.Mark; 254 Result : Boolean; 255 256 begin 257 if Esize (E) <= 8 then 258 Siz := Uint_8; 259 elsif Esize (E) <= 16 then 260 Siz := Uint_16; 261 elsif Esize (E) <= 32 then 262 Siz := Uint_32; 263 elsif Esize (E) <= 64 then 264 Siz := Uint_64; 265 else 266 Siz := Uint_128; 267 end if; 268 269 if Is_Modular_Integer_Type (E) or else Is_Enumeration_Type (E) then 270 Result := 271 Expr_Rep_Value (Type_Low_Bound (E)) = 0 272 and then 273 2 ** Siz - Expr_Rep_Value (Type_High_Bound (E)) = 1; 274 275 else 276 Result := 277 Expr_Rep_Value (Type_Low_Bound (E)) + 2 ** (Siz - 1) = 0 278 and then 279 2 ** (Siz - 1) - Expr_Rep_Value (Type_High_Bound (E)) = 1; 280 end if; 281 282 Release (Umark); 283 return Result; 284 end; 285 end if; 286 end Bounds_Match_Size; 287 288 -------------------------------- 289 -- Debug_Renaming_Declaration -- 290 -------------------------------- 291 292 function Debug_Renaming_Declaration (N : Node_Id) return Node_Id is 293 pragma Assert 294 (Nkind (N) in N_Object_Renaming_Declaration 295 | N_Package_Renaming_Declaration 296 | N_Exception_Renaming_Declaration); 297 298 Loc : constant Source_Ptr := Sloc (N); 299 Ent : constant Node_Id := Defining_Entity (N); 300 Nam : constant Node_Id := Name (N); 301 Ren : Node_Id; 302 Typ : Entity_Id; 303 Obj : Entity_Id; 304 Res : Node_Id; 305 306 Enable : Boolean := Nkind (N) = N_Package_Renaming_Declaration; 307 -- By default, we do not generate an encoding for renaming. This is 308 -- however done (in which case this is set to True) in a few cases: 309 -- - when a package is renamed, 310 -- - when the renaming involves a packed array, 311 -- - when the renaming involves a packed record. 312 313 Last_Is_Indexed_Comp : Boolean := False; 314 -- Whether the last subscript value was an indexed component access (XS) 315 316 procedure Enable_If_Packed_Array (N : Node_Id); 317 -- Enable encoding generation if N is a packed array 318 319 function Output_Subscript (N : Node_Id; S : String) return Boolean; 320 -- Outputs a single subscript value as ?nnn (subscript is compile time 321 -- known value with value nnn) or as ?e (subscript is local constant 322 -- with name e), where S supplies the proper string to use for ?. 323 -- Returns False if the subscript is not of an appropriate type to 324 -- output in one of these two forms. The result is prepended to the 325 -- name stored in Name_Buffer. 326 327 function Scope_Contains 328 (Outer : Entity_Id; 329 Inner : Entity_Id) 330 return Boolean; 331 -- Return whether Inner belongs to the Outer scope 332 333 ---------------------------- 334 -- Enable_If_Packed_Array -- 335 ---------------------------- 336 337 procedure Enable_If_Packed_Array (N : Node_Id) is 338 T : constant Entity_Id := Underlying_Type (Etype (N)); 339 340 begin 341 Enable := 342 Enable 343 or else 344 (Ekind (T) in Array_Kind 345 and then Present (Packed_Array_Impl_Type (T))); 346 end Enable_If_Packed_Array; 347 348 ---------------------- 349 -- Output_Subscript -- 350 ---------------------- 351 352 function Output_Subscript (N : Node_Id; S : String) return Boolean is 353 begin 354 if Compile_Time_Known_Value (N) then 355 Prepend_Uint_To_Buffer (Expr_Value (N)); 356 357 elsif Nkind (N) = N_Identifier 358 and then Scope_Contains (Scope (Entity (N)), Ent) 359 and then Ekind (Entity (N)) in E_Constant | E_In_Parameter 360 then 361 Prepend_String_To_Buffer (Get_Name_String (Chars (Entity (N)))); 362 363 else 364 return False; 365 end if; 366 367 Prepend_String_To_Buffer (S); 368 return True; 369 end Output_Subscript; 370 371 -------------------- 372 -- Scope_Contains -- 373 -------------------- 374 375 function Scope_Contains 376 (Outer : Entity_Id; 377 Inner : Entity_Id) 378 return Boolean 379 is 380 Cur : Entity_Id := Scope (Inner); 381 382 begin 383 while Present (Cur) loop 384 if Cur = Outer then 385 return True; 386 end if; 387 388 Cur := Scope (Cur); 389 end loop; 390 391 return False; 392 end Scope_Contains; 393 394 -- Start of processing for Debug_Renaming_Declaration 395 396 begin 397 if not Comes_From_Source (N) and then not Needs_Debug_Info (Ent) then 398 return Empty; 399 end if; 400 401 -- Get renamed entity and compute suffix 402 403 Name_Len := 0; 404 Ren := Nam; 405 loop 406 -- The expression that designates the renamed object is sometimes 407 -- expanded into bit-wise operations. We want to work instead on 408 -- array/record components accesses, so try to analyze the unexpanded 409 -- forms. 410 411 Ren := Original_Node (Ren); 412 413 case Nkind (Ren) is 414 when N_Expanded_Name 415 | N_Identifier 416 => 417 if No (Entity (Ren)) 418 or else not Present (Renamed_Entity_Or_Object (Entity (Ren))) 419 then 420 exit; 421 end if; 422 423 -- This is a renaming of a renaming: traverse until the final 424 -- renaming to see if anything is packed along the way. 425 426 Ren := Renamed_Entity_Or_Object (Entity (Ren)); 427 428 when N_Selected_Component => 429 declare 430 Sel_Id : constant Entity_Id := 431 Entity (Selector_Name (Ren)); 432 First_Bit : Uint; 433 434 begin 435 -- If the renaming involves a call to a primitive function, 436 -- we are out of the scope of renaming encodings. We will 437 -- very likely create a variable to hold the renamed value 438 -- anyway, so the renaming entity will be available in 439 -- debuggers. 440 441 exit when Ekind (Sel_Id) not in E_Component | E_Discriminant; 442 443 First_Bit := Normalized_First_Bit (Sel_Id); 444 Enable := 445 Enable 446 or else Is_Packed 447 (Underlying_Type (Etype (Prefix (Ren)))) 448 or else (Present (First_Bit) 449 and then First_Bit /= Uint_0); 450 end; 451 452 Prepend_String_To_Buffer 453 (Get_Name_String (Chars (Selector_Name (Ren)))); 454 Prepend_String_To_Buffer ("XR"); 455 Ren := Prefix (Ren); 456 Last_Is_Indexed_Comp := False; 457 458 when N_Indexed_Component => 459 declare 460 X : Node_Id; 461 462 begin 463 Enable_If_Packed_Array (Prefix (Ren)); 464 465 X := Last (Expressions (Ren)); 466 while Present (X) loop 467 if not Output_Subscript (X, "XS") then 468 Set_Materialize_Entity (Ent); 469 return Empty; 470 end if; 471 472 Prev (X); 473 Last_Is_Indexed_Comp := True; 474 end loop; 475 end; 476 477 Ren := Prefix (Ren); 478 479 when N_Slice => 480 481 -- Assuming X is an array: 482 -- X (Y1 .. Y2) (Y3) 483 484 -- is equivalent to: 485 -- X (Y3) 486 487 -- GDB cannot handle packed array slices, so avoid describing 488 -- the slice if we can avoid it. 489 490 if not Last_Is_Indexed_Comp then 491 Enable_If_Packed_Array (Prefix (Ren)); 492 Typ := Etype (First_Index (Etype (Ren))); 493 494 if not Output_Subscript (Type_High_Bound (Typ), "XS") then 495 Set_Materialize_Entity (Ent); 496 return Empty; 497 end if; 498 499 if not Output_Subscript (Type_Low_Bound (Typ), "XL") then 500 Set_Materialize_Entity (Ent); 501 return Empty; 502 end if; 503 504 Last_Is_Indexed_Comp := False; 505 end if; 506 507 Ren := Prefix (Ren); 508 509 when N_Explicit_Dereference => 510 Prepend_String_To_Buffer ("XA"); 511 Ren := Prefix (Ren); 512 Last_Is_Indexed_Comp := False; 513 514 -- For now, anything else simply results in no translation 515 516 when others => 517 Set_Materialize_Entity (Ent); 518 return Empty; 519 end case; 520 end loop; 521 522 -- If we found no reason here to emit an encoding, stop now 523 524 if not Enable then 525 Set_Materialize_Entity (Ent); 526 return Empty; 527 end if; 528 529 Prepend_String_To_Buffer ("___XE"); 530 531 -- Include the designation of the form of renaming 532 533 case Nkind (N) is 534 when N_Object_Renaming_Declaration => 535 Prepend_String_To_Buffer ("___XR"); 536 537 when N_Exception_Renaming_Declaration => 538 Prepend_String_To_Buffer ("___XRE"); 539 540 when N_Package_Renaming_Declaration => 541 Prepend_String_To_Buffer ("___XRP"); 542 543 when others => 544 return Empty; 545 end case; 546 547 -- Add the name of the renaming entity to the front 548 549 Prepend_String_To_Buffer (Get_Name_String (Chars (Ent))); 550 551 -- If it is a child unit create a fully qualified name, to disambiguate 552 -- multiple child units with the same name and different parents. 553 554 if Nkind (N) = N_Package_Renaming_Declaration 555 and then Is_Child_Unit (Ent) 556 then 557 Prepend_String_To_Buffer ("__"); 558 Prepend_String_To_Buffer 559 (Get_Name_String (Chars (Scope (Ent)))); 560 end if; 561 562 -- Create the special object whose name is the debug encoding for the 563 -- renaming declaration. 564 565 -- For now, the object name contains the suffix encoding for the renamed 566 -- object, but not the name of the leading entity. The object is linked 567 -- the renamed entity using the Debug_Renaming_Link field. Then the 568 -- Qualify_Entity_Name procedure uses this link to create the proper 569 -- fully qualified name. 570 571 -- The reason we do things this way is that we really need to copy the 572 -- qualification of the renamed entity, and it is really much easier to 573 -- do this after the renamed entity has itself been fully qualified. 574 575 Obj := Make_Defining_Identifier (Loc, Chars => Name_Enter); 576 Res := 577 Make_Object_Declaration (Loc, 578 Defining_Identifier => Obj, 579 Object_Definition => New_Occurrence_Of 580 (Standard_Debug_Renaming_Type, Loc)); 581 582 Set_Debug_Renaming_Link (Obj, Entity (Ren)); 583 584 Set_Debug_Info_Needed (Obj); 585 586 -- The renamed entity may be a temporary, e.g. the result of an 587 -- implicit dereference in an iterator. Indicate that the temporary 588 -- itself requires debug information. If the renamed entity comes 589 -- from source this is a no-op. 590 591 Set_Debug_Info_Needed (Entity (Ren)); 592 593 -- Mark the object as internal so that it won't be initialized when 594 -- pragma Initialize_Scalars or Normalize_Scalars is in use. 595 596 Set_Is_Internal (Obj); 597 598 return Res; 599 600 -- If we get an exception, just figure it is a case that we cannot 601 -- successfully handle using our current approach, since this is 602 -- only for debugging, no need to take the compilation with us. 603 604 exception 605 when others => 606 return Make_Null_Statement (Loc); 607 end Debug_Renaming_Declaration; 608 609 ---------------------- 610 -- Get_Encoded_Name -- 611 ---------------------- 612 613 -- Note: see spec for details on encodings 614 615 procedure Get_Encoded_Name (E : Entity_Id) is 616 Has_Suffix : Boolean; 617 618 begin 619 -- If not generating code, there is no need to create encoded names, and 620 -- problems when the back-end is called to annotate types without full 621 -- code generation. See comments in Get_External_Name for additional 622 -- details. 623 624 -- However we do create encoded names if the back end is active, even 625 -- if Operating_Mode got reset. Otherwise any serious error reported 626 -- by the backend calling Error_Msg changes the Compilation_Mode to 627 -- Check_Semantics, which disables the functionality of this routine, 628 -- causing the generation of spurious additional errors. 629 630 -- Couldn't we just test Original_Operating_Mode here? ??? 631 632 if Operating_Mode /= Generate_Code and then not Generating_Code then 633 return; 634 end if; 635 636 Get_Name_String (Chars (E)); 637 638 -- Nothing to do if we do not have a type 639 640 if not Is_Type (E) 641 642 -- Or if this is an enumeration base type 643 644 or else (Is_Enumeration_Type (E) and then Is_Base_Type (E)) 645 646 -- Or if this is a dummy type for a renaming 647 648 or else (Name_Len >= 3 and then 649 Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR") 650 651 or else (Name_Len >= 4 and then 652 (Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRE" 653 or else 654 Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRP")) 655 656 -- For all these cases, just return the name unchanged 657 658 then 659 Name_Buffer (Name_Len + 1) := ASCII.NUL; 660 return; 661 end if; 662 663 Has_Suffix := True; 664 665 -- Generate GNAT encodings when asked to for fixed-point case 666 667 if GNAT_Encodings = DWARF_GNAT_Encodings_All 668 and then Is_Fixed_Point_Type (E) 669 then 670 Get_External_Name (E, True, "XF_"); 671 Add_Real_To_Buffer (Delta_Value (E)); 672 673 if Small_Value (E) /= Delta_Value (E) then 674 Add_Str_To_Name_Buffer ("_"); 675 Add_Real_To_Buffer (Small_Value (E)); 676 end if; 677 678 -- Likewise for discrete case where bounds do not match size 679 680 elsif GNAT_Encodings = DWARF_GNAT_Encodings_All 681 and then Is_Discrete_Type (E) 682 and then not Bounds_Match_Size (E) 683 then 684 declare 685 Lo : constant Node_Id := Type_Low_Bound (E); 686 Hi : constant Node_Id := Type_High_Bound (E); 687 688 Lo_Con : constant Boolean := Compile_Time_Known_Value (Lo); 689 Hi_Con : constant Boolean := Compile_Time_Known_Value (Hi); 690 691 Lo_Discr : constant Boolean := 692 Nkind (Lo) = N_Identifier 693 and then Ekind (Entity (Lo)) = E_Discriminant; 694 695 Hi_Discr : constant Boolean := 696 Nkind (Hi) = N_Identifier 697 and then Ekind (Entity (Hi)) = E_Discriminant; 698 699 Lo_Encode : constant Boolean := Lo_Con or Lo_Discr; 700 Hi_Encode : constant Boolean := Hi_Con or Hi_Discr; 701 702 Biased : constant Boolean := Has_Biased_Representation (E); 703 704 begin 705 if Biased then 706 Get_External_Name (E, True, "XB"); 707 else 708 Get_External_Name (E, True, "XD"); 709 end if; 710 711 if Lo_Encode or Hi_Encode then 712 if Biased then 713 Add_Str_To_Name_Buffer ("_"); 714 else 715 if Lo_Encode then 716 if Hi_Encode then 717 Add_Str_To_Name_Buffer ("LU_"); 718 else 719 Add_Str_To_Name_Buffer ("L_"); 720 end if; 721 else 722 Add_Str_To_Name_Buffer ("U_"); 723 end if; 724 end if; 725 726 if Lo_Con then 727 Add_Uint_To_Buffer (Expr_Rep_Value (Lo)); 728 elsif Lo_Discr then 729 Get_Name_String_And_Append (Chars (Entity (Lo))); 730 end if; 731 732 if Lo_Encode and Hi_Encode then 733 Add_Str_To_Name_Buffer ("__"); 734 end if; 735 736 if Hi_Con then 737 Add_Uint_To_Buffer (Expr_Rep_Value (Hi)); 738 elsif Hi_Discr then 739 Get_Name_String_And_Append (Chars (Entity (Hi))); 740 end if; 741 end if; 742 end; 743 744 -- For all other cases, the encoded name is the normal type name 745 746 else 747 Has_Suffix := False; 748 Get_External_Name (E); 749 end if; 750 751 if Debug_Flag_B and then Has_Suffix then 752 Write_Str ("**** type "); 753 Write_Name (Chars (E)); 754 Write_Str (" is encoded as "); 755 Write_Str (Name_Buffer (1 .. Name_Len)); 756 Write_Eol; 757 end if; 758 759 Name_Buffer (Name_Len + 1) := ASCII.NUL; 760 end Get_Encoded_Name; 761 762 ----------------------- 763 -- Get_External_Name -- 764 ----------------------- 765 766 procedure Get_External_Name 767 (Entity : Entity_Id; 768 Has_Suffix : Boolean := False; 769 Suffix : String := "") 770 is 771 procedure Get_Qualified_Name_And_Append (Entity : Entity_Id); 772 -- Appends fully qualified name of given entity to Name_Buffer 773 774 ----------------------------------- 775 -- Get_Qualified_Name_And_Append -- 776 ----------------------------------- 777 778 procedure Get_Qualified_Name_And_Append (Entity : Entity_Id) is 779 begin 780 -- If the entity is a compilation unit, its scope is Standard, 781 -- there is no outer scope, and the no further qualification 782 -- is required. 783 784 -- If the front end has already computed a fully qualified name, 785 -- then it is also the case that no further qualification is 786 -- required. 787 788 if Present (Scope (Scope (Entity))) 789 and then not Has_Fully_Qualified_Name (Entity) 790 then 791 Get_Qualified_Name_And_Append (Scope (Entity)); 792 Add_Str_To_Name_Buffer ("__"); 793 Get_Name_String_And_Append (Chars (Entity)); 794 Append_Homonym_Number (Entity); 795 796 else 797 Get_Name_String_And_Append (Chars (Entity)); 798 end if; 799 end Get_Qualified_Name_And_Append; 800 801 -- Local variables 802 803 E : Entity_Id := Entity; 804 805 -- Start of processing for Get_External_Name 806 807 begin 808 -- If we are not in code generation mode, this procedure may still be 809 -- called from Back_End (more specifically - from gigi for doing type 810 -- representation annotation or some representation-specific checks). 811 -- But in this mode there is no need to mess with external names. 812 813 -- Furthermore, the call causes difficulties in this case because the 814 -- string representing the homonym number is not correctly reset as a 815 -- part of the call to Output_Homonym_Numbers_Suffix (which is not 816 -- called in gigi). 817 818 if Operating_Mode /= Generate_Code then 819 return; 820 end if; 821 822 Reset_Buffers; 823 824 -- If this is a child unit, we want the child 825 826 if Nkind (E) = N_Defining_Program_Unit_Name then 827 E := Defining_Identifier (Entity); 828 end if; 829 830 -- Case of interface name being used 831 832 if Ekind (E) in E_Constant 833 | E_Exception 834 | E_Function 835 | E_Procedure 836 | E_Variable 837 and then Present (Interface_Name (E)) 838 and then No (Address_Clause (E)) 839 and then not Has_Suffix 840 then 841 Append (Global_Name_Buffer, Strval (Interface_Name (E))); 842 843 -- All other cases besides the interface name case 844 845 else 846 -- If this is a library level subprogram (i.e. a subprogram that is a 847 -- compilation unit other than a subunit), then we prepend _ada_ to 848 -- ensure distinctions required as described in the spec. 849 850 -- Check explicitly for child units, because those are not flagged 851 -- as Compilation_Units by lib. Should they be ??? 852 853 if Is_Subprogram (E) 854 and then (Is_Compilation_Unit (E) or Is_Child_Unit (E)) 855 and then not Has_Suffix 856 then 857 Add_Str_To_Name_Buffer ("_ada_"); 858 end if; 859 860 -- If the entity is a subprogram instance that is not a compilation 861 -- unit, generate the name of the original Ada entity, which is the 862 -- one gdb needs. 863 864 if Is_Generic_Instance (E) 865 and then Is_Subprogram (E) 866 and then not Is_Compilation_Unit (Scope (E)) 867 and then Ekind (Scope (E)) in E_Package | E_Package_Body 868 and then Present (Related_Instance (Scope (E))) 869 then 870 E := Related_Instance (Scope (E)); 871 end if; 872 873 Get_Qualified_Name_And_Append (E); 874 end if; 875 876 if Has_Suffix then 877 Add_Str_To_Name_Buffer ("___"); 878 Add_Str_To_Name_Buffer (Suffix); 879 end if; 880 881 -- Add a special prefix to distinguish Ghost entities. In Ignored Ghost 882 -- mode, these entities should not leak in the "living" space and they 883 -- should be removed by the compiler in a post-processing pass. Thus, 884 -- the prefix allows anyone to check that the final executable indeed 885 -- does not contain such entities, in such a case. Do not insert this 886 -- prefix for compilation units, whose name is used as a basis for the 887 -- name of the generated elaboration procedure and (when appropriate) 888 -- the executable produced. Only insert this prefix once, for Ghost 889 -- entities declared inside other Ghost entities. Three leading 890 -- underscores are used so that "___ghost_" is a unique substring of 891 -- names produced for Ghost entities, while "__ghost_" can appear in 892 -- names of entities inside a child/local package called "Ghost". 893 894 -- The compiler-generated finalizer for an enabled Ghost unit is treated 895 -- specially, as its name must be known to the binder, which has no 896 -- knowledge of Ghost status. In that case, the finalizer is not marked 897 -- as Ghost so that no prefix is added. Note that the special ___ghost_ 898 -- prefix is retained when the Ghost unit is ignored, which still allows 899 -- inspecting the final executable for the presence of an ignored Ghost 900 -- finalizer procedure. 901 902 if Is_Ghost_Entity (E) 903 and then not Is_Compilation_Unit (E) 904 and then (Name_Len < 9 905 or else Name_Buffer (1 .. 9) /= "___ghost_") 906 then 907 Insert_Str_In_Name_Buffer ("___ghost_", 1); 908 end if; 909 910 Name_Buffer (Name_Len + 1) := ASCII.NUL; 911 end Get_External_Name; 912 913 -------------------------- 914 -- Get_Variant_Encoding -- 915 -------------------------- 916 917 procedure Get_Variant_Encoding (V : Node_Id) is 918 Choice : Node_Id; 919 920 procedure Choice_Val (Typ : Character; Choice : Node_Id); 921 -- Output encoded value for a single choice value. Typ is the key 922 -- character ('S', 'F', or 'T') that precedes the choice value. 923 924 ---------------- 925 -- Choice_Val -- 926 ---------------- 927 928 procedure Choice_Val (Typ : Character; Choice : Node_Id) is 929 begin 930 if Nkind (Choice) = N_Integer_Literal then 931 Add_Char_To_Name_Buffer (Typ); 932 Add_Uint_To_Buffer (Intval (Choice)); 933 934 -- Character literal with no entity present (this is the case 935 -- Standard.Character or Standard.Wide_Character as root type) 936 937 elsif Nkind (Choice) = N_Character_Literal 938 and then No (Entity (Choice)) 939 then 940 Add_Char_To_Name_Buffer (Typ); 941 Add_Uint_To_Buffer (Char_Literal_Value (Choice)); 942 943 else 944 declare 945 Ent : constant Entity_Id := Entity (Choice); 946 947 begin 948 if Ekind (Ent) = E_Enumeration_Literal then 949 Add_Char_To_Name_Buffer (Typ); 950 Add_Uint_To_Buffer (Enumeration_Rep (Ent)); 951 952 else 953 pragma Assert (Ekind (Ent) = E_Constant); 954 Choice_Val (Typ, Constant_Value (Ent)); 955 end if; 956 end; 957 end if; 958 end Choice_Val; 959 960 -- Start of processing for Get_Variant_Encoding 961 962 begin 963 Name_Len := 0; 964 965 Choice := First (Discrete_Choices (V)); 966 while Present (Choice) loop 967 if Nkind (Choice) = N_Others_Choice then 968 Add_Char_To_Name_Buffer ('O'); 969 970 elsif Nkind (Choice) = N_Range then 971 Choice_Val ('R', Low_Bound (Choice)); 972 Choice_Val ('T', High_Bound (Choice)); 973 974 elsif Is_Entity_Name (Choice) 975 and then Is_Type (Entity (Choice)) 976 then 977 Choice_Val ('R', Type_Low_Bound (Entity (Choice))); 978 Choice_Val ('T', Type_High_Bound (Entity (Choice))); 979 980 elsif Nkind (Choice) = N_Subtype_Indication then 981 declare 982 Rang : constant Node_Id := 983 Range_Expression (Constraint (Choice)); 984 begin 985 Choice_Val ('R', Low_Bound (Rang)); 986 Choice_Val ('T', High_Bound (Rang)); 987 end; 988 989 else 990 Choice_Val ('S', Choice); 991 end if; 992 993 Next (Choice); 994 end loop; 995 996 Name_Buffer (Name_Len + 1) := ASCII.NUL; 997 998 if Debug_Flag_B then 999 declare 1000 VP : constant Node_Id := Parent (V); -- Variant_Part 1001 CL : constant Node_Id := Parent (VP); -- Component_List 1002 RD : constant Node_Id := Parent (CL); -- Record_Definition 1003 FT : constant Node_Id := Parent (RD); -- Full_Type_Declaration 1004 1005 begin 1006 Write_Str ("**** variant for type "); 1007 Write_Name (Chars (Defining_Identifier (FT))); 1008 Write_Str (" is encoded as "); 1009 Write_Str (Name_Buffer (1 .. Name_Len)); 1010 Write_Eol; 1011 end; 1012 end if; 1013 end Get_Variant_Encoding; 1014 1015 ----------------------------------------- 1016 -- Build_Subprogram_Instance_Renamings -- 1017 ----------------------------------------- 1018 1019 procedure Build_Subprogram_Instance_Renamings 1020 (N : Node_Id; 1021 Wrapper : Entity_Id) 1022 is 1023 Loc : Source_Ptr; 1024 Decl : Node_Id; 1025 E : Entity_Id; 1026 1027 begin 1028 E := First_Entity (Wrapper); 1029 while Present (E) loop 1030 if Nkind (Parent (E)) = N_Object_Declaration 1031 and then Is_Elementary_Type (Etype (E)) 1032 then 1033 Loc := Sloc (Expression (Parent (E))); 1034 Decl := Make_Object_Renaming_Declaration (Loc, 1035 Defining_Identifier => 1036 Make_Defining_Identifier (Loc, Chars (E)), 1037 Subtype_Mark => New_Occurrence_Of (Etype (E), Loc), 1038 Name => New_Occurrence_Of (E, Loc)); 1039 1040 Append (Decl, Declarations (N)); 1041 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 1042 end if; 1043 1044 Next_Entity (E); 1045 end loop; 1046 end Build_Subprogram_Instance_Renamings; 1047 1048 ------------------------------------ 1049 -- Get_Secondary_DT_External_Name -- 1050 ------------------------------------ 1051 1052 procedure Get_Secondary_DT_External_Name 1053 (Typ : Entity_Id; 1054 Ancestor_Typ : Entity_Id; 1055 Suffix_Index : Int) 1056 is 1057 begin 1058 Get_External_Name (Typ); 1059 1060 if Ancestor_Typ /= Typ then 1061 declare 1062 Len : constant Natural := Name_Len; 1063 Save_Str : constant String (1 .. Name_Len) 1064 := Name_Buffer (1 .. Name_Len); 1065 begin 1066 Get_External_Name (Ancestor_Typ); 1067 1068 -- Append the extended name of the ancestor to the 1069 -- extended name of Typ 1070 1071 Name_Buffer (Len + 2 .. Len + Name_Len + 1) := 1072 Name_Buffer (1 .. Name_Len); 1073 Name_Buffer (1 .. Len) := Save_Str; 1074 Name_Buffer (Len + 1) := '_'; 1075 Name_Len := Len + Name_Len + 1; 1076 end; 1077 end if; 1078 1079 Add_Nat_To_Name_Buffer (Suffix_Index); 1080 end Get_Secondary_DT_External_Name; 1081 1082 --------------------------------- 1083 -- Make_Packed_Array_Impl_Type_Name -- 1084 --------------------------------- 1085 1086 function Make_Packed_Array_Impl_Type_Name 1087 (Typ : Entity_Id; 1088 Csize : Uint) 1089 return Name_Id 1090 is 1091 begin 1092 Get_Name_String (Chars (Typ)); 1093 Add_Str_To_Name_Buffer ("___XP"); 1094 Add_Uint_To_Buffer (Csize); 1095 return Name_Find; 1096 end Make_Packed_Array_Impl_Type_Name; 1097 1098 ----------------------------------- 1099 -- Output_Homonym_Numbers_Suffix -- 1100 ----------------------------------- 1101 1102 procedure Output_Homonym_Numbers_Suffix is 1103 J : Natural; 1104 1105 begin 1106 if Homonym_Len > 0 then 1107 1108 -- Check for all 1's, in which case we do not output 1109 1110 J := 1; 1111 loop 1112 exit when Homonym_Numbers (J) /= '1'; 1113 1114 -- If we reached end of string we do not output 1115 1116 if J = Homonym_Len then 1117 Homonym_Len := 0; 1118 return; 1119 end if; 1120 1121 exit when Homonym_Numbers (J + 1) /= '_'; 1122 J := J + 2; 1123 end loop; 1124 1125 -- If we exit the loop then suffix must be output 1126 1127 Add_Str_To_Name_Buffer ("__"); 1128 Add_Str_To_Name_Buffer (Homonym_Numbers (1 .. Homonym_Len)); 1129 Homonym_Len := 0; 1130 end if; 1131 end Output_Homonym_Numbers_Suffix; 1132 1133 ------------------------------ 1134 -- Prepend_String_To_Buffer -- 1135 ------------------------------ 1136 1137 procedure Prepend_String_To_Buffer (S : String) is 1138 N : constant Integer := S'Length; 1139 begin 1140 Name_Buffer (1 + N .. Name_Len + N) := Name_Buffer (1 .. Name_Len); 1141 Name_Buffer (1 .. N) := S; 1142 Name_Len := Name_Len + N; 1143 end Prepend_String_To_Buffer; 1144 1145 ---------------------------- 1146 -- Prepend_Uint_To_Buffer -- 1147 ---------------------------- 1148 1149 procedure Prepend_Uint_To_Buffer (U : Uint) is 1150 begin 1151 if U < 0 then 1152 Prepend_String_To_Buffer ("m"); 1153 Prepend_Uint_To_Buffer (-U); 1154 else 1155 UI_Image (U, Decimal); 1156 Prepend_String_To_Buffer (UI_Image_Buffer (1 .. UI_Image_Length)); 1157 end if; 1158 end Prepend_Uint_To_Buffer; 1159 1160 ------------------------------ 1161 -- Qualify_All_Entity_Names -- 1162 ------------------------------ 1163 1164 procedure Qualify_All_Entity_Names is 1165 E : Entity_Id; 1166 Ent : Entity_Id; 1167 Nod : Node_Id; 1168 1169 begin 1170 for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop 1171 Nod := Name_Qualify_Units.Table (J); 1172 1173 -- When a scoping construct is ignored Ghost, it is rewritten as 1174 -- a null statement. Skip such constructs as they no longer carry 1175 -- names. 1176 1177 if Nkind (Nod) = N_Null_Statement then 1178 goto Continue; 1179 end if; 1180 1181 E := Defining_Entity (Nod); 1182 Reset_Buffers; 1183 Qualify_Entity_Name (E); 1184 1185 -- Normally entities in the qualification list are scopes, but in the 1186 -- case of a library-level package renaming there is an associated 1187 -- variable that encodes the debugger name and that variable is 1188 -- entered in the list since it occurs in the Aux_Decls list of the 1189 -- compilation and doesn't have a normal scope. 1190 1191 if Ekind (E) /= E_Variable then 1192 Ent := First_Entity (E); 1193 while Present (Ent) loop 1194 Reset_Buffers; 1195 Qualify_Entity_Name (Ent); 1196 Next_Entity (Ent); 1197 1198 -- There are odd cases where Last_Entity (E) = E. This happens 1199 -- in the case of renaming of packages. This test avoids 1200 -- getting stuck in such cases. 1201 1202 exit when Ent = E; 1203 end loop; 1204 end if; 1205 1206 <<Continue>> 1207 null; 1208 end loop; 1209 end Qualify_All_Entity_Names; 1210 1211 ------------------------- 1212 -- Qualify_Entity_Name -- 1213 ------------------------- 1214 1215 procedure Qualify_Entity_Name (Ent : Entity_Id) is 1216 1217 Full_Qualify_Name : String (1 .. Name_Buffer'Length); 1218 Full_Qualify_Len : Natural := 0; 1219 -- Used to accumulate fully qualified name of subprogram 1220 1221 procedure Fully_Qualify_Name (E : Entity_Id); 1222 -- Used to qualify a subprogram or type name, where full 1223 -- qualification up to Standard is always used. Name is set 1224 -- in Full_Qualify_Name with the length in Full_Qualify_Len. 1225 -- Note that this routine does not prepend the _ada_ string 1226 -- required for library subprograms (this is done in the back end). 1227 1228 function Is_BNPE (S : Entity_Id) return Boolean; 1229 -- Determines if S is a BNPE, i.e. Body-Nested Package Entity, which 1230 -- is defined to be a package which is immediately nested within a 1231 -- package body. 1232 1233 function Qualify_Needed (S : Entity_Id) return Boolean; 1234 -- Given a scope, determines if the scope is to be included in the 1235 -- fully qualified name, True if so, False if not. Blocks and loops 1236 -- are excluded from a qualified name. 1237 1238 procedure Set_BNPE_Suffix (E : Entity_Id); 1239 -- Recursive routine to append the BNPE qualification suffix. Works 1240 -- from right to left with E being the current entity in the list. 1241 -- The result does NOT have the trailing n's and trailing b stripped. 1242 -- The caller must do this required stripping. 1243 1244 procedure Set_Entity_Name (E : Entity_Id); 1245 -- Internal recursive routine that does most of the work. This routine 1246 -- leaves the result sitting in Name_Buffer and Name_Len. 1247 1248 BNPE_Suffix_Needed : Boolean := False; 1249 -- Set true if a body-nested package entity suffix is required 1250 1251 Save_Chars : constant Name_Id := Chars (Ent); 1252 -- Save original name 1253 1254 ------------------------ 1255 -- Fully_Qualify_Name -- 1256 ------------------------ 1257 1258 procedure Fully_Qualify_Name (E : Entity_Id) is 1259 Discard : Boolean := False; 1260 1261 begin 1262 -- Ignore empty entry (can happen in error cases) 1263 1264 if No (E) then 1265 return; 1266 1267 -- If this we are qualifying entities local to a generic instance, 1268 -- use the name of the original instantiation, not that of the 1269 -- anonymous subprogram in the wrapper package, so that gdb doesn't 1270 -- have to know about these. 1271 1272 elsif Is_Generic_Instance (E) 1273 and then Is_Subprogram (E) 1274 and then not Comes_From_Source (E) 1275 and then not Is_Compilation_Unit (Scope (E)) 1276 then 1277 Fully_Qualify_Name (Related_Instance (Scope (E))); 1278 return; 1279 end if; 1280 1281 -- If we reached fully qualified name, then just copy it 1282 1283 if Has_Fully_Qualified_Name (E) then 1284 Get_Name_String (Chars (E)); 1285 Strip_Suffixes (Discard); 1286 Full_Qualify_Name (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); 1287 Full_Qualify_Len := Name_Len; 1288 Set_Has_Fully_Qualified_Name (Ent); 1289 1290 -- Case of non-fully qualified name 1291 1292 else 1293 if Scope (E) = Standard_Standard then 1294 Set_Has_Fully_Qualified_Name (Ent); 1295 else 1296 Fully_Qualify_Name (Scope (E)); 1297 Full_Qualify_Name (Full_Qualify_Len + 1) := '_'; 1298 Full_Qualify_Name (Full_Qualify_Len + 2) := '_'; 1299 Full_Qualify_Len := Full_Qualify_Len + 2; 1300 end if; 1301 1302 if Has_Qualified_Name (E) then 1303 Get_Unqualified_Name_String (Chars (E)); 1304 else 1305 Get_Name_String (Chars (E)); 1306 end if; 1307 1308 -- Here we do one step of the qualification 1309 1310 Full_Qualify_Name 1311 (Full_Qualify_Len + 1 .. Full_Qualify_Len + Name_Len) := 1312 Name_Buffer (1 .. Name_Len); 1313 Full_Qualify_Len := Full_Qualify_Len + Name_Len; 1314 Append_Homonym_Number (E); 1315 end if; 1316 1317 if Is_BNPE (E) then 1318 BNPE_Suffix_Needed := True; 1319 end if; 1320 end Fully_Qualify_Name; 1321 1322 ------------- 1323 -- Is_BNPE -- 1324 ------------- 1325 1326 function Is_BNPE (S : Entity_Id) return Boolean is 1327 begin 1328 return Ekind (S) = E_Package and then Is_Package_Body_Entity (S); 1329 end Is_BNPE; 1330 1331 -------------------- 1332 -- Qualify_Needed -- 1333 -------------------- 1334 1335 function Qualify_Needed (S : Entity_Id) return Boolean is 1336 begin 1337 -- If we got all the way to Standard, then we have certainly 1338 -- fully qualified the name, so set the flag appropriately, 1339 -- and then return False, since we are most certainly done. 1340 1341 if S = Standard_Standard then 1342 Set_Has_Fully_Qualified_Name (Ent, True); 1343 return False; 1344 1345 -- Otherwise figure out if further qualification is required 1346 1347 else 1348 return Is_Subprogram (Ent) 1349 or else Ekind (Ent) = E_Subprogram_Body 1350 or else (Ekind (S) /= E_Block 1351 and then Ekind (S) /= E_Loop 1352 and then not Is_Dynamic_Scope (S)); 1353 end if; 1354 end Qualify_Needed; 1355 1356 --------------------- 1357 -- Set_BNPE_Suffix -- 1358 --------------------- 1359 1360 procedure Set_BNPE_Suffix (E : Entity_Id) is 1361 S : constant Entity_Id := Scope (E); 1362 1363 begin 1364 if Qualify_Needed (S) then 1365 Set_BNPE_Suffix (S); 1366 1367 if Is_BNPE (E) then 1368 Add_Char_To_Name_Buffer ('b'); 1369 else 1370 Add_Char_To_Name_Buffer ('n'); 1371 end if; 1372 1373 else 1374 Add_Char_To_Name_Buffer ('X'); 1375 end if; 1376 end Set_BNPE_Suffix; 1377 1378 --------------------- 1379 -- Set_Entity_Name -- 1380 --------------------- 1381 1382 procedure Set_Entity_Name (E : Entity_Id) is 1383 S : constant Entity_Id := Scope (E); 1384 1385 begin 1386 -- If we reach an already qualified name, just take the encoding 1387 -- except that we strip the package body suffixes, since these 1388 -- will be separately put on later. 1389 1390 if Has_Qualified_Name (E) then 1391 Get_Name_String_And_Append (Chars (E)); 1392 Strip_Suffixes (BNPE_Suffix_Needed); 1393 1394 -- If the top level name we are adding is itself fully 1395 -- qualified, then that means that the name that we are 1396 -- preparing for the Fully_Qualify_Name call will also 1397 -- generate a fully qualified name. 1398 1399 if Has_Fully_Qualified_Name (E) then 1400 Set_Has_Fully_Qualified_Name (Ent); 1401 end if; 1402 1403 -- Case where upper level name is not encoded yet 1404 1405 else 1406 -- Recurse if further qualification required 1407 1408 if Qualify_Needed (S) then 1409 Set_Entity_Name (S); 1410 Add_Str_To_Name_Buffer ("__"); 1411 end if; 1412 1413 -- Otherwise get name and note if it is a BNPE 1414 1415 Get_Name_String_And_Append (Chars (E)); 1416 1417 if Is_BNPE (E) then 1418 BNPE_Suffix_Needed := True; 1419 end if; 1420 1421 Append_Homonym_Number (E); 1422 end if; 1423 end Set_Entity_Name; 1424 1425 -- Start of processing for Qualify_Entity_Name 1426 1427 begin 1428 if Has_Qualified_Name (Ent) then 1429 return; 1430 1431 -- If the entity is a variable encoding the debug name for an object 1432 -- renaming, then the qualified name of the entity associated with the 1433 -- renamed object can now be incorporated in the debug name. 1434 1435 elsif Ekind (Ent) = E_Variable 1436 and then Present (Debug_Renaming_Link (Ent)) 1437 then 1438 Name_Len := 0; 1439 Qualify_Entity_Name (Debug_Renaming_Link (Ent)); 1440 Get_Name_String (Chars (Ent)); 1441 1442 -- Retrieve the now-qualified name of the renamed entity and insert 1443 -- it in the middle of the name, just preceding the suffix encoding 1444 -- describing the renamed object. 1445 1446 declare 1447 Renamed_Id : constant String := 1448 Get_Name_String (Chars (Debug_Renaming_Link (Ent))); 1449 Insert_Len : constant Integer := Renamed_Id'Length + 1; 1450 Index : Natural := Name_Len - 3; 1451 1452 begin 1453 -- Loop backwards through the name to find the start of the "___" 1454 -- sequence associated with the suffix. 1455 1456 while Index >= Name_Buffer'First 1457 and then (Name_Buffer (Index + 1) /= '_' 1458 or else Name_Buffer (Index + 2) /= '_' 1459 or else Name_Buffer (Index + 3) /= '_') 1460 loop 1461 Index := Index - 1; 1462 end loop; 1463 1464 pragma Assert (Name_Buffer (Index + 1 .. Index + 3) = "___"); 1465 1466 -- Insert an underscore separator and the entity name just in 1467 -- front of the suffix. 1468 1469 Name_Buffer (Index + 1 + Insert_Len .. Name_Len + Insert_Len) := 1470 Name_Buffer (Index + 1 .. Name_Len); 1471 Name_Buffer (Index + 1) := '_'; 1472 Name_Buffer (Index + 2 .. Index + Insert_Len) := Renamed_Id; 1473 Name_Len := Name_Len + Insert_Len; 1474 end; 1475 1476 -- Reset the name of the variable to the new name that includes the 1477 -- name of the renamed entity. 1478 1479 Set_Chars (Ent, Name_Enter); 1480 1481 -- If the entity needs qualification by its scope then develop it 1482 -- here, add the variable's name, and again reset the entity name. 1483 1484 if Qualify_Needed (Scope (Ent)) then 1485 Name_Len := 0; 1486 Set_Entity_Name (Scope (Ent)); 1487 Add_Str_To_Name_Buffer ("__"); 1488 1489 Get_Name_String_And_Append (Chars (Ent)); 1490 1491 Set_Chars (Ent, Name_Enter); 1492 end if; 1493 1494 Set_Has_Qualified_Name (Ent); 1495 return; 1496 1497 elsif Is_Subprogram (Ent) 1498 or else Ekind (Ent) = E_Subprogram_Body 1499 or else Is_Type (Ent) 1500 or else Ekind (Ent) = E_Exception 1501 then 1502 Fully_Qualify_Name (Ent); 1503 Name_Len := Full_Qualify_Len; 1504 Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len); 1505 1506 -- Qualification needed for enumeration literals when generating C code 1507 -- (to simplify their management in the backend). 1508 1509 elsif Modify_Tree_For_C 1510 and then Ekind (Ent) = E_Enumeration_Literal 1511 and then Scope (Ultimate_Alias (Ent)) /= Standard_Standard 1512 then 1513 Fully_Qualify_Name (Ent); 1514 Name_Len := Full_Qualify_Len; 1515 Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len); 1516 1517 elsif Qualify_Needed (Scope (Ent)) then 1518 Name_Len := 0; 1519 Set_Entity_Name (Ent); 1520 1521 else 1522 Set_Has_Qualified_Name (Ent); 1523 1524 -- If a variable is hidden by a subsequent loop variable, qualify 1525 -- the name of that loop variable to prevent visibility issues when 1526 -- translating to C. Note that gdb probably never handled properly 1527 -- this accidental hiding, given that loops are not scopes at 1528 -- runtime. We also qualify a name if it hides an outer homonym, 1529 -- and both are declared in blocks. 1530 1531 if Modify_Tree_For_C and then Ekind (Ent) = E_Variable then 1532 if Present (Hiding_Loop_Variable (Ent)) then 1533 declare 1534 Var : constant Entity_Id := Hiding_Loop_Variable (Ent); 1535 1536 begin 1537 Set_Entity_Name (Var); 1538 Add_Str_To_Name_Buffer ("L"); 1539 Set_Chars (Var, Name_Enter); 1540 end; 1541 1542 elsif Present (Homonym (Ent)) 1543 and then Ekind (Scope (Ent)) = E_Block 1544 and then Ekind (Scope (Homonym (Ent))) = E_Block 1545 then 1546 Set_Entity_Name (Ent); 1547 Add_Str_To_Name_Buffer ("B"); 1548 Set_Chars (Ent, Name_Enter); 1549 end if; 1550 end if; 1551 1552 return; 1553 end if; 1554 1555 -- Fall through with a fully qualified name in Name_Buffer/Name_Len 1556 1557 Output_Homonym_Numbers_Suffix; 1558 1559 -- Add body-nested package suffix if required 1560 1561 if BNPE_Suffix_Needed 1562 and then Ekind (Ent) /= E_Enumeration_Literal 1563 then 1564 Set_BNPE_Suffix (Ent); 1565 1566 -- Strip trailing n's and last trailing b as required. Note that 1567 -- we know there is at least one b, or no suffix would be generated. 1568 1569 while Name_Buffer (Name_Len) = 'n' loop 1570 Name_Len := Name_Len - 1; 1571 end loop; 1572 1573 Name_Len := Name_Len - 1; 1574 end if; 1575 1576 Set_Chars (Ent, Name_Enter); 1577 Set_Has_Qualified_Name (Ent); 1578 1579 if Debug_Flag_BB then 1580 Write_Str ("*** "); 1581 Write_Name (Save_Chars); 1582 Write_Str (" qualified as "); 1583 Write_Name (Chars (Ent)); 1584 Write_Eol; 1585 end if; 1586 end Qualify_Entity_Name; 1587 1588 -------------------------- 1589 -- Qualify_Entity_Names -- 1590 -------------------------- 1591 1592 procedure Qualify_Entity_Names (N : Node_Id) is 1593 begin 1594 Name_Qualify_Units.Append (N); 1595 end Qualify_Entity_Names; 1596 1597 ------------------- 1598 -- Reset_Buffers -- 1599 ------------------- 1600 1601 procedure Reset_Buffers is 1602 begin 1603 Name_Len := 0; 1604 Homonym_Len := 0; 1605 end Reset_Buffers; 1606 1607 -------------------- 1608 -- Strip_Suffixes -- 1609 -------------------- 1610 1611 procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is 1612 SL : Natural; 1613 1614 pragma Warnings (Off, BNPE_Suffix_Found); 1615 -- Since this procedure only ever sets the flag 1616 1617 begin 1618 -- Search for and strip BNPE suffix 1619 1620 for J in reverse 2 .. Name_Len loop 1621 if Name_Buffer (J) = 'X' then 1622 Name_Len := J - 1; 1623 BNPE_Suffix_Found := True; 1624 exit; 1625 end if; 1626 1627 exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n'; 1628 end loop; 1629 1630 -- Search for and strip homonym numbers suffix 1631 1632 for J in reverse 2 .. Name_Len - 2 loop 1633 if Name_Buffer (J) = '_' 1634 and then Name_Buffer (J + 1) = '_' 1635 then 1636 if Name_Buffer (J + 2) in '0' .. '9' then 1637 if Homonym_Len > 0 then 1638 Homonym_Len := Homonym_Len + 1; 1639 Homonym_Numbers (Homonym_Len) := '-'; 1640 end if; 1641 1642 SL := Name_Len - (J + 1); 1643 1644 Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) := 1645 Name_Buffer (J + 2 .. Name_Len); 1646 Name_Len := J - 1; 1647 Homonym_Len := Homonym_Len + SL; 1648 end if; 1649 1650 exit; 1651 end if; 1652 end loop; 1653 end Strip_Suffixes; 1654 1655end Exp_Dbug; 1656