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