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