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