gcc/ada/exp_dbug.adb

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