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