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